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) 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) then
 826         do i=1,nct
 827           do j=1,3
 828             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 829             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 830           enddo
 831         enddo
 832       endif
 833 #ifdef DEBUG
 834       write (iout,*) "gloc before adding corr"
 835       do i=1,4*nres
 836         write (iout,*) i,gloc(i,icg)
 837       enddo
 838 #endif
 839       do i=1,nres-3
 840         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 841      &   +wcorr5*g_corr5_loc(i)
 842      &   +wcorr6*g_corr6_loc(i)
 843      &   +wturn4*gel_loc_turn4(i)
 844      &   +wturn3*gel_loc_turn3(i)
 845      &   +wturn6*gel_loc_turn6(i)
 846      &   +wel_loc*gel_loc_loc(i)
 847       enddo
 848 #ifdef DEBUG
 849       write (iout,*) "gloc after adding corr"
 850       do i=1,4*nres
 851         write (iout,*) i,gloc(i,icg)
 852       enddo
 853 #endif
 854 #ifdef MPI
 855       if (nfgtasks.gt.1) then
 856         do j=1,3
 857           do i=1,nres
 858             gradbufc(j,i)=gradc(j,i,icg)
 859             gradbufx(j,i)=gradx(j,i,icg)
 860           enddo
 861         enddo
 862         do i=1,4*nres
 863           glocbuf(i)=gloc(i,icg)
 864         enddo
 865 #ifdef DEBUG
 866       write (iout,*) "gloc_sc before reduce"
 867       do i=1,nres
 868        do j=1,3
 869         write (iout,*) i,j,gloc_sc(j,i,icg)
 870        enddo
 871       enddo
 872 #endif
 873         do i=1,nres
 874          do j=1,3
 875           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 876          enddo
 877         enddo
 878         time00=MPI_Wtime()
 879         call MPI_Barrier(FG_COMM,IERR)
 880         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 881         time00=MPI_Wtime()
 882         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 883      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 884         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 885      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 886         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 887      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 888         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 889      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 890         time_reduce=time_reduce+MPI_Wtime()-time00
 891 #ifdef DEBUG
 892       write (iout,*) "gloc_sc after reduce"
 893       do i=1,nres
 894        do j=1,3
 895         write (iout,*) i,j,gloc_sc(j,i,icg)
 896        enddo
 897       enddo
 898 #endif
 899 #ifdef DEBUG
 900       write (iout,*) "gloc after reduce"
 901       do i=1,4*nres
 902         write (iout,*) i,gloc(i,icg)
 903       enddo
 904 #endif
 905       endif
 906 #endif
 907       if (gnorm_check) then
 908 c
 909 c Compute the maximum elements of the gradient
 910 c
 911       gvdwc_max=0.0d0
 912       gvdwc_scp_max=0.0d0
 913       gelc_max=0.0d0
 914       gvdwpp_max=0.0d0
 915       gradb_max=0.0d0
 916       ghpbc_max=0.0d0
 917       gradcorr_max=0.0d0
 918       gel_loc_max=0.0d0
 919       gcorr3_turn_max=0.0d0
 920       gcorr4_turn_max=0.0d0
 921       gradcorr5_max=0.0d0
 922       gradcorr6_max=0.0d0
 923       gcorr6_turn_max=0.0d0
 924       gsccorc_max=0.0d0
 925       gscloc_max=0.0d0
 926       gvdwx_max=0.0d0
 927       gradx_scp_max=0.0d0
 928       ghpbx_max=0.0d0
 929       gradxorr_max=0.0d0
 930       gsccorx_max=0.0d0
 931       gsclocx_max=0.0d0
 932       do i=1,nct
 933         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 934         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 935 #ifdef TSCSC
 936         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 937         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 938 #endif
 939         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 940         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 941      &   gvdwc_scp_max=gvdwc_scp_norm
 942         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 943         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 944         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 945         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 946         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 947         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 948         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 949         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 950         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 951         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 952         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 953         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 954         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 955      &    gcorr3_turn(1,i)))
 956         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 957      &    gcorr3_turn_max=gcorr3_turn_norm
 958         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 959      &    gcorr4_turn(1,i)))
 960         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 961      &    gcorr4_turn_max=gcorr4_turn_norm
 962         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 963         if (gradcorr5_norm.gt.gradcorr5_max)
 964      &    gradcorr5_max=gradcorr5_norm
 965         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 966         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 967         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 968      &    gcorr6_turn(1,i)))
 969         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 970      &    gcorr6_turn_max=gcorr6_turn_norm
 971         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 972         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 973         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 974         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 975         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 976         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 977 #ifdef TSCSC
 978         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 979         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 980 #endif
 981         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 982         if (gradx_scp_norm.gt.gradx_scp_max)
 983      &    gradx_scp_max=gradx_scp_norm
 984         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 985         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 986         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 987         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 988         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 989         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 990         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 991         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 992       enddo
 993       if (gradout) then
 994 #ifdef AIX
 995         open(istat,file=statname,position="append")
 996 #else
 997         open(istat,file=statname,access="append")
 998 #endif
 999         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1000      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1001      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1002      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1003      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1004      &     gsccorx_max,gsclocx_max
1005         close(istat)
1006         if (gvdwc_max.gt.1.0d4) then
1007           write (iout,*) "gvdwc gvdwx gradb gradbx"
1008           do i=nnt,nct
1009             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1010      &        gradb(j,i),gradbx(j,i),j=1,3)
1011           enddo
1012           call pdbout(0.0d0,'cipiszcze',iout)
1013           call flush(iout)
1014         endif
1015       endif
1016       endif
1017 #ifdef DEBUG
1018       write (iout,*) "gradc gradx gloc"
1019       do i=1,nres
1020         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1021      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1022       enddo
1023 #endif
1024 #ifdef TIMING
1025 #ifdef MPI
1026       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1027 #else
1028       time_sumgradient=time_sumgradient+tcpu()-time01
1029 #endif
1030 #endif
1031       return
1032       end
1033 c-------------------------------------------------------------------------------
1034       subroutine rescale_weights(t_bath)
1035       implicit real*8 (a-h,o-z)
1036       include 'DIMENSIONS'
1037       include 'COMMON.IOUNITS'
1038       include 'COMMON.FFIELD'
1039       include 'COMMON.SBRIDGE'
1040       double precision kfac /2.4d0/
1041       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1042 c      facT=temp0/t_bath
1043 c      facT=2*temp0/(t_bath+temp0)
1044       if (rescale_mode.eq.0) then
1045         facT=1.0d0
1046         facT2=1.0d0
1047         facT3=1.0d0
1048         facT4=1.0d0
1049         facT5=1.0d0
1050       else if (rescale_mode.eq.1) then
1051         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1052         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1053         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1054         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1055         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1056       else if (rescale_mode.eq.2) then
1057         x=t_bath/temp0
1058         x2=x*x
1059         x3=x2*x
1060         x4=x3*x
1061         x5=x4*x
1062         facT=licznik/dlog(dexp(x)+dexp(-x))
1063         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1064         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1065         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1066         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1067       else
1068         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1069         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1070 #ifdef MPI
1071        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1072 #endif
1073        stop 555
1074       endif
1075       welec=weights(3)*fact
1076       wcorr=weights(4)*fact3
1077       wcorr5=weights(5)*fact4
1078       wcorr6=weights(6)*fact5
1079       wel_loc=weights(7)*fact2
1080       wturn3=weights(8)*fact2
1081       wturn4=weights(9)*fact3
1082       wturn6=weights(10)*fact5
1083       wtor=weights(13)*fact
1084       wtor_d=weights(14)*fact2
1085       wsccor=weights(21)*fact
1086 #ifdef TSCSC
1087 c      wsct=t_bath/temp0
1088       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1089 #endif
1090       return
1091       end
1092 C------------------------------------------------------------------------
1093       subroutine enerprint(energia)
1094       implicit real*8 (a-h,o-z)
1095       include 'DIMENSIONS'
1096       include 'COMMON.IOUNITS'
1097       include 'COMMON.FFIELD'
1098       include 'COMMON.SBRIDGE'
1099       include 'COMMON.MD'
1100       double precision energia(0:n_ene)
1101       etot=energia(0)
1102 #ifdef TSCSC
1103       evdw=energia(22)+wsct*energia(23)
1104 #else
1105       evdw=energia(1)
1106 #endif
1107       evdw2=energia(2)
1108 #ifdef SCP14
1109       evdw2=energia(2)+energia(18)
1110 #else
1111       evdw2=energia(2)
1112 #endif
1113       ees=energia(3)
1114 #ifdef SPLITELE
1115       evdw1=energia(16)
1116 #endif
1117       ecorr=energia(4)
1118       ecorr5=energia(5)
1119       ecorr6=energia(6)
1120       eel_loc=energia(7)
1121       eello_turn3=energia(8)
1122       eello_turn4=energia(9)
1123       eello_turn6=energia(10)
1124       ebe=energia(11)
1125       escloc=energia(12)
1126       etors=energia(13)
1127       etors_d=energia(14)
1128       ehpb=energia(15)
1129       edihcnstr=energia(19)
1130       estr=energia(17)
1131       Uconst=energia(20)
1132       esccor=energia(21)
1133       ehomology_constr=energia(24)
1134 C     Bartek
1135       edfadis = energia(25)
1136       edfator = energia(26)
1137       edfanei = energia(27)
1138       edfabet = energia(28)
1139
1140 #ifdef SPLITELE
1141       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1142      &  estr,wbond,ebe,wang,
1143      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1144      &  ecorr,wcorr,
1145      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1146      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1147      &  edihcnstr,ehomology_constr, ebr*nss,
1148      &  Uconst,edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1149      &  edfabet,wdfa_beta,etot
1150    10 format (/'Virtual-chain energies:'//
1151      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1152      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1153      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1154      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1155      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1156      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1157      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1158      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1159      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1160      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1161      & ' (SS bridges & dist. cnstr.)'/
1162      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1163      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1164      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1165      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1166      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1167      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1168      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1169      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1170      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1171      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1172      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1173      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1174      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1175      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1176      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1177      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1178      & 'ETOT=  ',1pE16.6,' (total)')
1179 #else
1180       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1181      &  estr,wbond,ebe,wang,
1182      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1183      &  ecorr,wcorr,
1184      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1185      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1186      &  ehomology_constr,ebr*nss,Uconst,edfadis,wdfa_dist,edfator,
1187      &  wdfa_tor,edfanei,wdfa_nei,edfabet,wdfa_beta,
1188      &  etot
1189    10 format (/'Virtual-chain energies:'//
1190      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1191      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1192      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1193      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1194      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1195      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1196      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1197      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1198      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1199      & ' (SS bridges & dist. cnstr.)'/
1200      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1201      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1202      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1203      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1204      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1205      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1206      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1207      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1208      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1209      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1210      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1211      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1212      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
1213      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
1214      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
1215      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
1216      & 'ETOT=  ',1pE16.6,' (total)')
1217 #endif
1218       return
1219       end
1220 C-----------------------------------------------------------------------
1221       subroutine elj(evdw,evdw_p,evdw_m)
1222 C
1223 C This subroutine calculates the interaction energy of nonbonded side chains
1224 C assuming the LJ potential of interaction.
1225 C
1226       implicit real*8 (a-h,o-z)
1227       include 'DIMENSIONS'
1228       parameter (accur=1.0d-10)
1229       include 'COMMON.GEO'
1230       include 'COMMON.VAR'
1231       include 'COMMON.LOCAL'
1232       include 'COMMON.CHAIN'
1233       include 'COMMON.DERIV'
1234       include 'COMMON.INTERACT'
1235       include 'COMMON.TORSION'
1236       include 'COMMON.SBRIDGE'
1237       include 'COMMON.NAMES'
1238       include 'COMMON.IOUNITS'
1239       include 'COMMON.CONTACTS'
1240       dimension gg(3)
1241 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1242       evdw=0.0D0
1243       do i=iatsc_s,iatsc_e
1244         itypi=itype(i)
1245         itypi1=itype(i+1)
1246         xi=c(1,nres+i)
1247         yi=c(2,nres+i)
1248         zi=c(3,nres+i)
1249 C Change 12/1/95
1250         num_conti=0
1251 C
1252 C Calculate SC interaction energy.
1253 C
1254         do iint=1,nint_gr(i)
1255 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1256 cd   &                  'iend=',iend(i,iint)
1257           do j=istart(i,iint),iend(i,iint)
1258             itypj=itype(j)
1259             xj=c(1,nres+j)-xi
1260             yj=c(2,nres+j)-yi
1261             zj=c(3,nres+j)-zi
1262 C Change 12/1/95 to calculate four-body interactions
1263             rij=xj*xj+yj*yj+zj*zj
1264             rrij=1.0D0/rij
1265 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1266             eps0ij=eps(itypi,itypj)
1267             fac=rrij**expon2
1268             e1=fac*fac*aa(itypi,itypj)
1269             e2=fac*bb(itypi,itypj)
1270             evdwij=e1+e2
1271 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1272 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1273 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1274 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1275 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1276 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1277 #ifdef TSCSC
1278             if (bb(itypi,itypj).gt.0) then
1279                evdw_p=evdw_p+evdwij
1280             else
1281                evdw_m=evdw_m+evdwij
1282             endif
1283 #else
1284             evdw=evdw+evdwij
1285 #endif
1286 C
1287 C Calculate the components of the gradient in DC and X
1288 C
1289             fac=-rrij*(e1+evdwij)
1290             gg(1)=xj*fac
1291             gg(2)=yj*fac
1292             gg(3)=zj*fac
1293 #ifdef TSCSC
1294             if (bb(itypi,itypj).gt.0.0d0) then
1295               do k=1,3
1296                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1297                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1298                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1299                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1300               enddo
1301             else
1302               do k=1,3
1303                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1304                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1305                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1306                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1307               enddo
1308             endif
1309 #else
1310             do k=1,3
1311               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1312               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1313               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1314               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1315             enddo
1316 #endif
1317 cgrad            do k=i,j-1
1318 cgrad              do l=1,3
1319 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1320 cgrad              enddo
1321 cgrad            enddo
1322 C
1323 C 12/1/95, revised on 5/20/97
1324 C
1325 C Calculate the contact function. The ith column of the array JCONT will
1326 C contain the numbers of atoms that make contacts with the atom I (of numbers
1327 C greater than I). The arrays FACONT and GACONT will contain the values of
1328 C the contact function and its derivative.
1329 C
1330 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1331 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1332 C Uncomment next line, if the correlation interactions are contact function only
1333             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1334               rij=dsqrt(rij)
1335               sigij=sigma(itypi,itypj)
1336               r0ij=rs0(itypi,itypj)
1337 C
1338 C Check whether the SC's are not too far to make a contact.
1339 C
1340               rcut=1.5d0*r0ij
1341               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1342 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1343 C
1344               if (fcont.gt.0.0D0) then
1345 C If the SC-SC distance if close to sigma, apply spline.
1346 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1347 cAdam &             fcont1,fprimcont1)
1348 cAdam           fcont1=1.0d0-fcont1
1349 cAdam           if (fcont1.gt.0.0d0) then
1350 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1351 cAdam             fcont=fcont*fcont1
1352 cAdam           endif
1353 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1354 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1355 cga             do k=1,3
1356 cga               gg(k)=gg(k)*eps0ij
1357 cga             enddo
1358 cga             eps0ij=-evdwij*eps0ij
1359 C Uncomment for AL's type of SC correlation interactions.
1360 cadam           eps0ij=-evdwij
1361                 num_conti=num_conti+1
1362                 jcont(num_conti,i)=j
1363                 facont(num_conti,i)=fcont*eps0ij
1364                 fprimcont=eps0ij*fprimcont/rij
1365                 fcont=expon*fcont
1366 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1367 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1368 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1369 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1370                 gacont(1,num_conti,i)=-fprimcont*xj
1371                 gacont(2,num_conti,i)=-fprimcont*yj
1372                 gacont(3,num_conti,i)=-fprimcont*zj
1373 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1374 cd              write (iout,'(2i3,3f10.5)')
1375 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1376               endif
1377             endif
1378           enddo      ! j
1379         enddo        ! iint
1380 C Change 12/1/95
1381         num_cont(i)=num_conti
1382       enddo          ! i
1383       do i=1,nct
1384         do j=1,3
1385           gvdwc(j,i)=expon*gvdwc(j,i)
1386           gvdwx(j,i)=expon*gvdwx(j,i)
1387         enddo
1388       enddo
1389 C******************************************************************************
1390 C
1391 C                              N O T E !!!
1392 C
1393 C To save time, the factor of EXPON has been extracted from ALL components
1394 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1395 C use!
1396 C
1397 C******************************************************************************
1398       return
1399       end
1400 C-----------------------------------------------------------------------------
1401       subroutine eljk(evdw,evdw_p,evdw_m)
1402 C
1403 C This subroutine calculates the interaction energy of nonbonded side chains
1404 C assuming the LJK potential of interaction.
1405 C
1406       implicit real*8 (a-h,o-z)
1407       include 'DIMENSIONS'
1408       include 'COMMON.GEO'
1409       include 'COMMON.VAR'
1410       include 'COMMON.LOCAL'
1411       include 'COMMON.CHAIN'
1412       include 'COMMON.DERIV'
1413       include 'COMMON.INTERACT'
1414       include 'COMMON.IOUNITS'
1415       include 'COMMON.NAMES'
1416       dimension gg(3)
1417       logical scheck
1418 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1419       evdw=0.0D0
1420       do i=iatsc_s,iatsc_e
1421         itypi=itype(i)
1422         itypi1=itype(i+1)
1423         xi=c(1,nres+i)
1424         yi=c(2,nres+i)
1425         zi=c(3,nres+i)
1426 C
1427 C Calculate SC interaction energy.
1428 C
1429         do iint=1,nint_gr(i)
1430           do j=istart(i,iint),iend(i,iint)
1431             itypj=itype(j)
1432             xj=c(1,nres+j)-xi
1433             yj=c(2,nres+j)-yi
1434             zj=c(3,nres+j)-zi
1435             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1436             fac_augm=rrij**expon
1437             e_augm=augm(itypi,itypj)*fac_augm
1438             r_inv_ij=dsqrt(rrij)
1439             rij=1.0D0/r_inv_ij
1440             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1441             fac=r_shift_inv**expon
1442             e1=fac*fac*aa(itypi,itypj)
1443             e2=fac*bb(itypi,itypj)
1444             evdwij=e_augm+e1+e2
1445 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1446 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1447 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1448 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1449 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1450 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1451 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1452 #ifdef TSCSC
1453             if (bb(itypi,itypj).gt.0) then
1454                evdw_p=evdw_p+evdwij
1455             else
1456                evdw_m=evdw_m+evdwij
1457             endif
1458 #else
1459             evdw=evdw+evdwij
1460 #endif
1461 C
1462 C Calculate the components of the gradient in DC and X
1463 C
1464             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1465             gg(1)=xj*fac
1466             gg(2)=yj*fac
1467             gg(3)=zj*fac
1468 #ifdef TSCSC
1469             if (bb(itypi,itypj).gt.0.0d0) then
1470               do k=1,3
1471                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1472                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1473                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1474                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1475               enddo
1476             else
1477               do k=1,3
1478                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1479                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1480                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1481                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1482               enddo
1483             endif
1484 #else
1485             do k=1,3
1486               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1487               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1488               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1489               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1490             enddo
1491 #endif
1492 cgrad            do k=i,j-1
1493 cgrad              do l=1,3
1494 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1495 cgrad              enddo
1496 cgrad            enddo
1497           enddo      ! j
1498         enddo        ! iint
1499       enddo          ! i
1500       do i=1,nct
1501         do j=1,3
1502           gvdwc(j,i)=expon*gvdwc(j,i)
1503           gvdwx(j,i)=expon*gvdwx(j,i)
1504         enddo
1505       enddo
1506       return
1507       end
1508 C-----------------------------------------------------------------------------
1509       subroutine ebp(evdw,evdw_p,evdw_m)
1510 C
1511 C This subroutine calculates the interaction energy of nonbonded side chains
1512 C assuming the Berne-Pechukas potential of interaction.
1513 C
1514       implicit real*8 (a-h,o-z)
1515       include 'DIMENSIONS'
1516       include 'COMMON.GEO'
1517       include 'COMMON.VAR'
1518       include 'COMMON.LOCAL'
1519       include 'COMMON.CHAIN'
1520       include 'COMMON.DERIV'
1521       include 'COMMON.NAMES'
1522       include 'COMMON.INTERACT'
1523       include 'COMMON.IOUNITS'
1524       include 'COMMON.CALC'
1525       common /srutu/ icall
1526 c     double precision rrsave(maxdim)
1527       logical lprn
1528       evdw=0.0D0
1529 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1530       evdw=0.0D0
1531 c     if (icall.eq.0) then
1532 c       lprn=.true.
1533 c     else
1534         lprn=.false.
1535 c     endif
1536       ind=0
1537       do i=iatsc_s,iatsc_e
1538         itypi=itype(i)
1539         itypi1=itype(i+1)
1540         xi=c(1,nres+i)
1541         yi=c(2,nres+i)
1542         zi=c(3,nres+i)
1543         dxi=dc_norm(1,nres+i)
1544         dyi=dc_norm(2,nres+i)
1545         dzi=dc_norm(3,nres+i)
1546 c        dsci_inv=dsc_inv(itypi)
1547         dsci_inv=vbld_inv(i+nres)
1548 C
1549 C Calculate SC interaction energy.
1550 C
1551         do iint=1,nint_gr(i)
1552           do j=istart(i,iint),iend(i,iint)
1553             ind=ind+1
1554             itypj=itype(j)
1555 c            dscj_inv=dsc_inv(itypj)
1556             dscj_inv=vbld_inv(j+nres)
1557             chi1=chi(itypi,itypj)
1558             chi2=chi(itypj,itypi)
1559             chi12=chi1*chi2
1560             chip1=chip(itypi)
1561             chip2=chip(itypj)
1562             chip12=chip1*chip2
1563             alf1=alp(itypi)
1564             alf2=alp(itypj)
1565             alf12=0.5D0*(alf1+alf2)
1566 C For diagnostics only!!!
1567 c           chi1=0.0D0
1568 c           chi2=0.0D0
1569 c           chi12=0.0D0
1570 c           chip1=0.0D0
1571 c           chip2=0.0D0
1572 c           chip12=0.0D0
1573 c           alf1=0.0D0
1574 c           alf2=0.0D0
1575 c           alf12=0.0D0
1576             xj=c(1,nres+j)-xi
1577             yj=c(2,nres+j)-yi
1578             zj=c(3,nres+j)-zi
1579             dxj=dc_norm(1,nres+j)
1580             dyj=dc_norm(2,nres+j)
1581             dzj=dc_norm(3,nres+j)
1582             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1583 cd          if (icall.eq.0) then
1584 cd            rrsave(ind)=rrij
1585 cd          else
1586 cd            rrij=rrsave(ind)
1587 cd          endif
1588             rij=dsqrt(rrij)
1589 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1590             call sc_angular
1591 C Calculate whole angle-dependent part of epsilon and contributions
1592 C to its derivatives
1593             fac=(rrij*sigsq)**expon2
1594             e1=fac*fac*aa(itypi,itypj)
1595             e2=fac*bb(itypi,itypj)
1596             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1597             eps2der=evdwij*eps3rt
1598             eps3der=evdwij*eps2rt
1599             evdwij=evdwij*eps2rt*eps3rt
1600 #ifdef TSCSC
1601             if (bb(itypi,itypj).gt.0) then
1602                evdw_p=evdw_p+evdwij
1603             else
1604                evdw_m=evdw_m+evdwij
1605             endif
1606 #else
1607             evdw=evdw+evdwij
1608 #endif
1609             if (lprn) then
1610             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1611             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1612 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1613 cd     &        restyp(itypi),i,restyp(itypj),j,
1614 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1615 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1616 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1617 cd     &        evdwij
1618             endif
1619 C Calculate gradient components.
1620             e1=e1*eps1*eps2rt**2*eps3rt**2
1621             fac=-expon*(e1+evdwij)
1622             sigder=fac/sigsq
1623             fac=rrij*fac
1624 C Calculate radial part of the gradient
1625             gg(1)=xj*fac
1626             gg(2)=yj*fac
1627             gg(3)=zj*fac
1628 C Calculate the angular part of the gradient and sum add the contributions
1629 C to the appropriate components of the Cartesian gradient.
1630 #ifdef TSCSC
1631             if (bb(itypi,itypj).gt.0) then
1632                call sc_grad
1633             else
1634                call sc_grad_T
1635             endif
1636 #else
1637             call sc_grad
1638 #endif
1639           enddo      ! j
1640         enddo        ! iint
1641       enddo          ! i
1642 c     stop
1643       return
1644       end
1645 C-----------------------------------------------------------------------------
1646       subroutine egb(evdw,evdw_p,evdw_m)
1647 C
1648 C This subroutine calculates the interaction energy of nonbonded side chains
1649 C assuming the Gay-Berne potential of interaction.
1650 C
1651       implicit real*8 (a-h,o-z)
1652       include 'DIMENSIONS'
1653       include 'COMMON.GEO'
1654       include 'COMMON.VAR'
1655       include 'COMMON.LOCAL'
1656       include 'COMMON.CHAIN'
1657       include 'COMMON.DERIV'
1658       include 'COMMON.NAMES'
1659       include 'COMMON.INTERACT'
1660       include 'COMMON.IOUNITS'
1661       include 'COMMON.CALC'
1662       include 'COMMON.CONTROL'
1663       include 'COMMON.SBRIDGE'
1664       logical lprn
1665       evdw=0.0D0
1666 ccccc      energy_dec=.false.
1667 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1668       evdw=0.0D0
1669       evdw_p=0.0D0
1670       evdw_m=0.0D0
1671       lprn=.false.
1672 c     if (icall.eq.0) lprn=.false.
1673       ind=0
1674       do i=iatsc_s,iatsc_e
1675         itypi=itype(i)
1676         itypi1=itype(i+1)
1677         xi=c(1,nres+i)
1678         yi=c(2,nres+i)
1679         zi=c(3,nres+i)
1680         dxi=dc_norm(1,nres+i)
1681         dyi=dc_norm(2,nres+i)
1682         dzi=dc_norm(3,nres+i)
1683 c        dsci_inv=dsc_inv(itypi)
1684         dsci_inv=vbld_inv(i+nres)
1685 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1686 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1687 C
1688 C Calculate SC interaction energy.
1689 C
1690         do iint=1,nint_gr(i)
1691           do j=istart(i,iint),iend(i,iint)
1692             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1693               call dyn_ssbond_ene(i,j,evdwij)
1694               evdw=evdw+evdwij
1695               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1696      &                        'evdw',i,j,evdwij,' ss'
1697             ELSE
1698             ind=ind+1
1699             itypj=itype(j)
1700 c            dscj_inv=dsc_inv(itypj)
1701             dscj_inv=vbld_inv(j+nres)
1702 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1703 c     &       1.0d0/vbld(j+nres)
1704 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1705             sig0ij=sigma(itypi,itypj)
1706             chi1=chi(itypi,itypj)
1707             chi2=chi(itypj,itypi)
1708             chi12=chi1*chi2
1709             chip1=chip(itypi)
1710             chip2=chip(itypj)
1711             chip12=chip1*chip2
1712             alf1=alp(itypi)
1713             alf2=alp(itypj)
1714             alf12=0.5D0*(alf1+alf2)
1715 C For diagnostics only!!!
1716 c           chi1=0.0D0
1717 c           chi2=0.0D0
1718 c           chi12=0.0D0
1719 c           chip1=0.0D0
1720 c           chip2=0.0D0
1721 c           chip12=0.0D0
1722 c           alf1=0.0D0
1723 c           alf2=0.0D0
1724 c           alf12=0.0D0
1725             xj=c(1,nres+j)-xi
1726             yj=c(2,nres+j)-yi
1727             zj=c(3,nres+j)-zi
1728             dxj=dc_norm(1,nres+j)
1729             dyj=dc_norm(2,nres+j)
1730             dzj=dc_norm(3,nres+j)
1731 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1732 c            write (iout,*) "j",j," dc_norm",
1733 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1734             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1735             rij=dsqrt(rrij)
1736 C Calculate angle-dependent terms of energy and contributions to their
1737 C derivatives.
1738             call sc_angular
1739             sigsq=1.0D0/sigsq
1740             sig=sig0ij*dsqrt(sigsq)
1741             rij_shift=1.0D0/rij-sig+sig0ij
1742 c for diagnostics; uncomment
1743 c            rij_shift=1.2*sig0ij
1744 C I hate to put IF's in the loops, but here don't have another choice!!!!
1745             if (rij_shift.le.0.0D0) then
1746               evdw=1.0D20
1747 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1748 cd     &        restyp(itypi),i,restyp(itypj),j,
1749 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1750               return
1751             endif
1752             sigder=-sig*sigsq
1753 c---------------------------------------------------------------
1754             rij_shift=1.0D0/rij_shift
1755             fac=rij_shift**expon
1756             e1=fac*fac*aa(itypi,itypj)
1757             e2=fac*bb(itypi,itypj)
1758             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1759             eps2der=evdwij*eps3rt
1760             eps3der=evdwij*eps2rt
1761 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1762 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1763             evdwij=evdwij*eps2rt*eps3rt
1764 #ifdef TSCSC
1765             if (bb(itypi,itypj).gt.0) then
1766                evdw_p=evdw_p+evdwij
1767             else
1768                evdw_m=evdw_m+evdwij
1769             endif
1770 #else
1771             evdw=evdw+evdwij
1772 #endif
1773             if (lprn) then
1774             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1775             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1776             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1777      &        restyp(itypi),i,restyp(itypj),j,
1778      &        epsi,sigm,chi1,chi2,chip1,chip2,
1779      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1780      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1781      &        evdwij
1782             endif
1783
1784             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1785      &                        'evdw',i,j,evdwij
1786
1787 C Calculate gradient components.
1788             e1=e1*eps1*eps2rt**2*eps3rt**2
1789             fac=-expon*(e1+evdwij)*rij_shift
1790             sigder=fac*sigder
1791             fac=rij*fac
1792 c            fac=0.0d0
1793 C Calculate the radial part of the gradient
1794             gg(1)=xj*fac
1795             gg(2)=yj*fac
1796             gg(3)=zj*fac
1797 C Calculate angular part of the gradient.
1798 #ifdef TSCSC
1799             if (bb(itypi,itypj).gt.0) then
1800                call sc_grad
1801             else
1802                call sc_grad_T
1803             endif
1804 #else
1805             call sc_grad
1806 #endif
1807             ENDIF    ! dyn_ss
1808           enddo      ! j
1809         enddo        ! iint
1810       enddo          ! i
1811 c      write (iout,*) "Number of loop steps in EGB:",ind
1812 cccc      energy_dec=.false.
1813       return
1814       end
1815 C-----------------------------------------------------------------------------
1816       subroutine egbv(evdw,evdw_p,evdw_m)
1817 C
1818 C This subroutine calculates the interaction energy of nonbonded side chains
1819 C assuming the Gay-Berne-Vorobjev potential of interaction.
1820 C
1821       implicit real*8 (a-h,o-z)
1822       include 'DIMENSIONS'
1823       include 'COMMON.GEO'
1824       include 'COMMON.VAR'
1825       include 'COMMON.LOCAL'
1826       include 'COMMON.CHAIN'
1827       include 'COMMON.DERIV'
1828       include 'COMMON.NAMES'
1829       include 'COMMON.INTERACT'
1830       include 'COMMON.IOUNITS'
1831       include 'COMMON.CALC'
1832       common /srutu/ icall
1833       logical lprn
1834       evdw=0.0D0
1835 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1836       evdw=0.0D0
1837       lprn=.false.
1838 c     if (icall.eq.0) lprn=.true.
1839       ind=0
1840       do i=iatsc_s,iatsc_e
1841         itypi=itype(i)
1842         itypi1=itype(i+1)
1843         xi=c(1,nres+i)
1844         yi=c(2,nres+i)
1845         zi=c(3,nres+i)
1846         dxi=dc_norm(1,nres+i)
1847         dyi=dc_norm(2,nres+i)
1848         dzi=dc_norm(3,nres+i)
1849 c        dsci_inv=dsc_inv(itypi)
1850         dsci_inv=vbld_inv(i+nres)
1851 C
1852 C Calculate SC interaction energy.
1853 C
1854         do iint=1,nint_gr(i)
1855           do j=istart(i,iint),iend(i,iint)
1856             ind=ind+1
1857             itypj=itype(j)
1858 c            dscj_inv=dsc_inv(itypj)
1859             dscj_inv=vbld_inv(j+nres)
1860             sig0ij=sigma(itypi,itypj)
1861             r0ij=r0(itypi,itypj)
1862             chi1=chi(itypi,itypj)
1863             chi2=chi(itypj,itypi)
1864             chi12=chi1*chi2
1865             chip1=chip(itypi)
1866             chip2=chip(itypj)
1867             chip12=chip1*chip2
1868             alf1=alp(itypi)
1869             alf2=alp(itypj)
1870             alf12=0.5D0*(alf1+alf2)
1871 C For diagnostics only!!!
1872 c           chi1=0.0D0
1873 c           chi2=0.0D0
1874 c           chi12=0.0D0
1875 c           chip1=0.0D0
1876 c           chip2=0.0D0
1877 c           chip12=0.0D0
1878 c           alf1=0.0D0
1879 c           alf2=0.0D0
1880 c           alf12=0.0D0
1881             xj=c(1,nres+j)-xi
1882             yj=c(2,nres+j)-yi
1883             zj=c(3,nres+j)-zi
1884             dxj=dc_norm(1,nres+j)
1885             dyj=dc_norm(2,nres+j)
1886             dzj=dc_norm(3,nres+j)
1887             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1888             rij=dsqrt(rrij)
1889 C Calculate angle-dependent terms of energy and contributions to their
1890 C derivatives.
1891             call sc_angular
1892             sigsq=1.0D0/sigsq
1893             sig=sig0ij*dsqrt(sigsq)
1894             rij_shift=1.0D0/rij-sig+r0ij
1895 C I hate to put IF's in the loops, but here don't have another choice!!!!
1896             if (rij_shift.le.0.0D0) then
1897               evdw=1.0D20
1898               return
1899             endif
1900             sigder=-sig*sigsq
1901 c---------------------------------------------------------------
1902             rij_shift=1.0D0/rij_shift
1903             fac=rij_shift**expon
1904             e1=fac*fac*aa(itypi,itypj)
1905             e2=fac*bb(itypi,itypj)
1906             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1907             eps2der=evdwij*eps3rt
1908             eps3der=evdwij*eps2rt
1909             fac_augm=rrij**expon
1910             e_augm=augm(itypi,itypj)*fac_augm
1911             evdwij=evdwij*eps2rt*eps3rt
1912 #ifdef TSCSC
1913             if (bb(itypi,itypj).gt.0) then
1914                evdw_p=evdw_p+evdwij+e_augm
1915             else
1916                evdw_m=evdw_m+evdwij+e_augm
1917             endif
1918 #else
1919             evdw=evdw+evdwij+e_augm
1920 #endif
1921             if (lprn) then
1922             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1923             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1924             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1925      &        restyp(itypi),i,restyp(itypj),j,
1926      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1927      &        chi1,chi2,chip1,chip2,
1928      &        eps1,eps2rt**2,eps3rt**2,
1929      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1930      &        evdwij+e_augm
1931             endif
1932 C Calculate gradient components.
1933             e1=e1*eps1*eps2rt**2*eps3rt**2
1934             fac=-expon*(e1+evdwij)*rij_shift
1935             sigder=fac*sigder
1936             fac=rij*fac-2*expon*rrij*e_augm
1937 C Calculate the radial part of the gradient
1938             gg(1)=xj*fac
1939             gg(2)=yj*fac
1940             gg(3)=zj*fac
1941 C Calculate angular part of the gradient.
1942 #ifdef TSCSC
1943             if (bb(itypi,itypj).gt.0) then
1944                call sc_grad
1945             else
1946                call sc_grad_T
1947             endif
1948 #else
1949             call sc_grad
1950 #endif
1951           enddo      ! j
1952         enddo        ! iint
1953       enddo          ! i
1954       end
1955 C-----------------------------------------------------------------------------
1956       subroutine sc_angular
1957 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1958 C om12. Called by ebp, egb, and egbv.
1959       implicit none
1960       include 'COMMON.CALC'
1961       include 'COMMON.IOUNITS'
1962       erij(1)=xj*rij
1963       erij(2)=yj*rij
1964       erij(3)=zj*rij
1965       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1966       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1967       om12=dxi*dxj+dyi*dyj+dzi*dzj
1968       chiom12=chi12*om12
1969 C Calculate eps1(om12) and its derivative in om12
1970       faceps1=1.0D0-om12*chiom12
1971       faceps1_inv=1.0D0/faceps1
1972       eps1=dsqrt(faceps1_inv)
1973 C Following variable is eps1*deps1/dom12
1974       eps1_om12=faceps1_inv*chiom12
1975 c diagnostics only
1976 c      faceps1_inv=om12
1977 c      eps1=om12
1978 c      eps1_om12=1.0d0
1979 c      write (iout,*) "om12",om12," eps1",eps1
1980 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1981 C and om12.
1982       om1om2=om1*om2
1983       chiom1=chi1*om1
1984       chiom2=chi2*om2
1985       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1986       sigsq=1.0D0-facsig*faceps1_inv
1987       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1988       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1989       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1990 c diagnostics only
1991 c      sigsq=1.0d0
1992 c      sigsq_om1=0.0d0
1993 c      sigsq_om2=0.0d0
1994 c      sigsq_om12=0.0d0
1995 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1996 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1997 c     &    " eps1",eps1
1998 C Calculate eps2 and its derivatives in om1, om2, and om12.
1999       chipom1=chip1*om1
2000       chipom2=chip2*om2
2001       chipom12=chip12*om12
2002       facp=1.0D0-om12*chipom12
2003       facp_inv=1.0D0/facp
2004       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2005 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2006 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2007 C Following variable is the square root of eps2
2008       eps2rt=1.0D0-facp1*facp_inv
2009 C Following three variables are the derivatives of the square root of eps
2010 C in om1, om2, and om12.
2011       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2012       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2013       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2014 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2015       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2016 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2017 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2018 c     &  " eps2rt_om12",eps2rt_om12
2019 C Calculate whole angle-dependent part of epsilon and contributions
2020 C to its derivatives
2021       return
2022       end
2023
2024 C----------------------------------------------------------------------------
2025       subroutine sc_grad_T
2026       implicit real*8 (a-h,o-z)
2027       include 'DIMENSIONS'
2028       include 'COMMON.CHAIN'
2029       include 'COMMON.DERIV'
2030       include 'COMMON.CALC'
2031       include 'COMMON.IOUNITS'
2032       double precision dcosom1(3),dcosom2(3)
2033       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2034       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2035       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2036      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2037 c diagnostics only
2038 c      eom1=0.0d0
2039 c      eom2=0.0d0
2040 c      eom12=evdwij*eps1_om12
2041 c end diagnostics
2042 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2043 c     &  " sigder",sigder
2044 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2045 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2046       do k=1,3
2047         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2048         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2049       enddo
2050       do k=1,3
2051         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2052       enddo
2053 c      write (iout,*) "gg",(gg(k),k=1,3)
2054       do k=1,3
2055         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
2056      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2057      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2058         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
2059      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2060      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2061 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2062 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2063 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2064 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2065       enddo
2066 C
2067 C Calculate the components of the gradient in DC and X
2068 C
2069 cgrad      do k=i,j-1
2070 cgrad        do l=1,3
2071 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2072 cgrad        enddo
2073 cgrad      enddo
2074       do l=1,3
2075         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
2076         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
2077       enddo
2078       return
2079       end
2080
2081 C----------------------------------------------------------------------------
2082       subroutine sc_grad
2083       implicit real*8 (a-h,o-z)
2084       include 'DIMENSIONS'
2085       include 'COMMON.CHAIN'
2086       include 'COMMON.DERIV'
2087       include 'COMMON.CALC'
2088       include 'COMMON.IOUNITS'
2089       double precision dcosom1(3),dcosom2(3)
2090       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2091       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2092       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2093      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2094 c diagnostics only
2095 c      eom1=0.0d0
2096 c      eom2=0.0d0
2097 c      eom12=evdwij*eps1_om12
2098 c end diagnostics
2099 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2100 c     &  " sigder",sigder
2101 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2102 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2103       do k=1,3
2104         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2105         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2106       enddo
2107       do k=1,3
2108         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2109       enddo
2110 c      write (iout,*) "gg",(gg(k),k=1,3)
2111       do k=1,3
2112         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2113      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2114      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2115         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2116      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2117      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2118 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2119 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2120 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2121 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2122       enddo
2123 C
2124 C Calculate the components of the gradient in DC and X
2125 C
2126 cgrad      do k=i,j-1
2127 cgrad        do l=1,3
2128 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2129 cgrad        enddo
2130 cgrad      enddo
2131       do l=1,3
2132         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2133         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2134       enddo
2135       return
2136       end
2137 C-----------------------------------------------------------------------
2138       subroutine e_softsphere(evdw)
2139 C
2140 C This subroutine calculates the interaction energy of nonbonded side chains
2141 C assuming the LJ potential of interaction.
2142 C
2143       implicit real*8 (a-h,o-z)
2144       include 'DIMENSIONS'
2145       parameter (accur=1.0d-10)
2146       include 'COMMON.GEO'
2147       include 'COMMON.VAR'
2148       include 'COMMON.LOCAL'
2149       include 'COMMON.CHAIN'
2150       include 'COMMON.DERIV'
2151       include 'COMMON.INTERACT'
2152       include 'COMMON.TORSION'
2153       include 'COMMON.SBRIDGE'
2154       include 'COMMON.NAMES'
2155       include 'COMMON.IOUNITS'
2156       include 'COMMON.CONTACTS'
2157       dimension gg(3)
2158 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2159       evdw=0.0D0
2160       do i=iatsc_s,iatsc_e
2161         itypi=itype(i)
2162         itypi1=itype(i+1)
2163         xi=c(1,nres+i)
2164         yi=c(2,nres+i)
2165         zi=c(3,nres+i)
2166 C
2167 C Calculate SC interaction energy.
2168 C
2169         do iint=1,nint_gr(i)
2170 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2171 cd   &                  'iend=',iend(i,iint)
2172           do j=istart(i,iint),iend(i,iint)
2173             itypj=itype(j)
2174             xj=c(1,nres+j)-xi
2175             yj=c(2,nres+j)-yi
2176             zj=c(3,nres+j)-zi
2177             rij=xj*xj+yj*yj+zj*zj
2178 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2179             r0ij=r0(itypi,itypj)
2180             r0ijsq=r0ij*r0ij
2181 c            print *,i,j,r0ij,dsqrt(rij)
2182             if (rij.lt.r0ijsq) then
2183               evdwij=0.25d0*(rij-r0ijsq)**2
2184               fac=rij-r0ijsq
2185             else
2186               evdwij=0.0d0
2187               fac=0.0d0
2188             endif
2189             evdw=evdw+evdwij
2190 C
2191 C Calculate the components of the gradient in DC and X
2192 C
2193             gg(1)=xj*fac
2194             gg(2)=yj*fac
2195             gg(3)=zj*fac
2196             do k=1,3
2197               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2198               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2199               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2200               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2201             enddo
2202 cgrad            do k=i,j-1
2203 cgrad              do l=1,3
2204 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2205 cgrad              enddo
2206 cgrad            enddo
2207           enddo ! j
2208         enddo ! iint
2209       enddo ! i
2210       return
2211       end
2212 C--------------------------------------------------------------------------
2213       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2214      &              eello_turn4)
2215 C
2216 C Soft-sphere potential of p-p interaction
2217 C
2218       implicit real*8 (a-h,o-z)
2219       include 'DIMENSIONS'
2220       include 'COMMON.CONTROL'
2221       include 'COMMON.IOUNITS'
2222       include 'COMMON.GEO'
2223       include 'COMMON.VAR'
2224       include 'COMMON.LOCAL'
2225       include 'COMMON.CHAIN'
2226       include 'COMMON.DERIV'
2227       include 'COMMON.INTERACT'
2228       include 'COMMON.CONTACTS'
2229       include 'COMMON.TORSION'
2230       include 'COMMON.VECTORS'
2231       include 'COMMON.FFIELD'
2232       dimension ggg(3)
2233 cd      write(iout,*) 'In EELEC_soft_sphere'
2234       ees=0.0D0
2235       evdw1=0.0D0
2236       eel_loc=0.0d0
2237       eello_turn3=0.0d0
2238       eello_turn4=0.0d0
2239       ind=0
2240       do i=iatel_s,iatel_e
2241         dxi=dc(1,i)
2242         dyi=dc(2,i)
2243         dzi=dc(3,i)
2244         xmedi=c(1,i)+0.5d0*dxi
2245         ymedi=c(2,i)+0.5d0*dyi
2246         zmedi=c(3,i)+0.5d0*dzi
2247         num_conti=0
2248 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2249         do j=ielstart(i),ielend(i)
2250           ind=ind+1
2251           iteli=itel(i)
2252           itelj=itel(j)
2253           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2254           r0ij=rpp(iteli,itelj)
2255           r0ijsq=r0ij*r0ij
2256           dxj=dc(1,j)
2257           dyj=dc(2,j)
2258           dzj=dc(3,j)
2259           xj=c(1,j)+0.5D0*dxj-xmedi
2260           yj=c(2,j)+0.5D0*dyj-ymedi
2261           zj=c(3,j)+0.5D0*dzj-zmedi
2262           rij=xj*xj+yj*yj+zj*zj
2263           if (rij.lt.r0ijsq) then
2264             evdw1ij=0.25d0*(rij-r0ijsq)**2
2265             fac=rij-r0ijsq
2266           else
2267             evdw1ij=0.0d0
2268             fac=0.0d0
2269           endif
2270           evdw1=evdw1+evdw1ij
2271 C
2272 C Calculate contributions to the Cartesian gradient.
2273 C
2274           ggg(1)=fac*xj
2275           ggg(2)=fac*yj
2276           ggg(3)=fac*zj
2277           do k=1,3
2278             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2279             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2280           enddo
2281 *
2282 * Loop over residues i+1 thru j-1.
2283 *
2284 cgrad          do k=i+1,j-1
2285 cgrad            do l=1,3
2286 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2287 cgrad            enddo
2288 cgrad          enddo
2289         enddo ! j
2290       enddo   ! i
2291 cgrad      do i=nnt,nct-1
2292 cgrad        do k=1,3
2293 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2294 cgrad        enddo
2295 cgrad        do j=i+1,nct-1
2296 cgrad          do k=1,3
2297 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2298 cgrad          enddo
2299 cgrad        enddo
2300 cgrad      enddo
2301       return
2302       end
2303 c------------------------------------------------------------------------------
2304       subroutine vec_and_deriv
2305       implicit real*8 (a-h,o-z)
2306       include 'DIMENSIONS'
2307 #ifdef MPI
2308       include 'mpif.h'
2309 #endif
2310       include 'COMMON.IOUNITS'
2311       include 'COMMON.GEO'
2312       include 'COMMON.VAR'
2313       include 'COMMON.LOCAL'
2314       include 'COMMON.CHAIN'
2315       include 'COMMON.VECTORS'
2316       include 'COMMON.SETUP'
2317       include 'COMMON.TIME1'
2318       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2319 C Compute the local reference systems. For reference system (i), the
2320 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2321 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2322 #ifdef PARVEC
2323       do i=ivec_start,ivec_end
2324 #else
2325       do i=1,nres-1
2326 #endif
2327           if (i.eq.nres-1) then
2328 C Case of the last full residue
2329 C Compute the Z-axis
2330             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2331             costh=dcos(pi-theta(nres))
2332             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2333             do k=1,3
2334               uz(k,i)=fac*uz(k,i)
2335             enddo
2336 C Compute the derivatives of uz
2337             uzder(1,1,1)= 0.0d0
2338             uzder(2,1,1)=-dc_norm(3,i-1)
2339             uzder(3,1,1)= dc_norm(2,i-1)
2340             uzder(1,2,1)= dc_norm(3,i-1)
2341             uzder(2,2,1)= 0.0d0
2342             uzder(3,2,1)=-dc_norm(1,i-1)
2343             uzder(1,3,1)=-dc_norm(2,i-1)
2344             uzder(2,3,1)= dc_norm(1,i-1)
2345             uzder(3,3,1)= 0.0d0
2346             uzder(1,1,2)= 0.0d0
2347             uzder(2,1,2)= dc_norm(3,i)
2348             uzder(3,1,2)=-dc_norm(2,i)
2349             uzder(1,2,2)=-dc_norm(3,i)
2350             uzder(2,2,2)= 0.0d0
2351             uzder(3,2,2)= dc_norm(1,i)
2352             uzder(1,3,2)= dc_norm(2,i)
2353             uzder(2,3,2)=-dc_norm(1,i)
2354             uzder(3,3,2)= 0.0d0
2355 C Compute the Y-axis
2356             facy=fac
2357             do k=1,3
2358               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2359             enddo
2360 C Compute the derivatives of uy
2361             do j=1,3
2362               do k=1,3
2363                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2364      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2365                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2366               enddo
2367               uyder(j,j,1)=uyder(j,j,1)-costh
2368               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2369             enddo
2370             do j=1,2
2371               do k=1,3
2372                 do l=1,3
2373                   uygrad(l,k,j,i)=uyder(l,k,j)
2374                   uzgrad(l,k,j,i)=uzder(l,k,j)
2375                 enddo
2376               enddo
2377             enddo
2378             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2379             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2380             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2381             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2382           else
2383 C Other residues
2384 C Compute the Z-axis
2385             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2386             costh=dcos(pi-theta(i+2))
2387             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2388             do k=1,3
2389               uz(k,i)=fac*uz(k,i)
2390             enddo
2391 C Compute the derivatives of uz
2392             uzder(1,1,1)= 0.0d0
2393             uzder(2,1,1)=-dc_norm(3,i+1)
2394             uzder(3,1,1)= dc_norm(2,i+1)
2395             uzder(1,2,1)= dc_norm(3,i+1)
2396             uzder(2,2,1)= 0.0d0
2397             uzder(3,2,1)=-dc_norm(1,i+1)
2398             uzder(1,3,1)=-dc_norm(2,i+1)
2399             uzder(2,3,1)= dc_norm(1,i+1)
2400             uzder(3,3,1)= 0.0d0
2401             uzder(1,1,2)= 0.0d0
2402             uzder(2,1,2)= dc_norm(3,i)
2403             uzder(3,1,2)=-dc_norm(2,i)
2404             uzder(1,2,2)=-dc_norm(3,i)
2405             uzder(2,2,2)= 0.0d0
2406             uzder(3,2,2)= dc_norm(1,i)
2407             uzder(1,3,2)= dc_norm(2,i)
2408             uzder(2,3,2)=-dc_norm(1,i)
2409             uzder(3,3,2)= 0.0d0
2410 C Compute the Y-axis
2411             facy=fac
2412             do k=1,3
2413               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2414             enddo
2415 C Compute the derivatives of uy
2416             do j=1,3
2417               do k=1,3
2418                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2419      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2420                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2421               enddo
2422               uyder(j,j,1)=uyder(j,j,1)-costh
2423               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2424             enddo
2425             do j=1,2
2426               do k=1,3
2427                 do l=1,3
2428                   uygrad(l,k,j,i)=uyder(l,k,j)
2429                   uzgrad(l,k,j,i)=uzder(l,k,j)
2430                 enddo
2431               enddo
2432             enddo
2433             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2434             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2435             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2436             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2437           endif
2438       enddo
2439       do i=1,nres-1
2440         vbld_inv_temp(1)=vbld_inv(i+1)
2441         if (i.lt.nres-1) then
2442           vbld_inv_temp(2)=vbld_inv(i+2)
2443           else
2444           vbld_inv_temp(2)=vbld_inv(i)
2445           endif
2446         do j=1,2
2447           do k=1,3
2448             do l=1,3
2449               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2450               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2451             enddo
2452           enddo
2453         enddo
2454       enddo
2455 #if defined(PARVEC) && defined(MPI)
2456       if (nfgtasks1.gt.1) then
2457         time00=MPI_Wtime()
2458 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2459 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2460 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2461         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2462      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2463      &   FG_COMM1,IERR)
2464         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2465      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2466      &   FG_COMM1,IERR)
2467         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2468      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2469      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2470         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2471      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2472      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2473         time_gather=time_gather+MPI_Wtime()-time00
2474       endif
2475 c      if (fg_rank.eq.0) then
2476 c        write (iout,*) "Arrays UY and UZ"
2477 c        do i=1,nres-1
2478 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2479 c     &     (uz(k,i),k=1,3)
2480 c        enddo
2481 c      endif
2482 #endif
2483       return
2484       end
2485 C-----------------------------------------------------------------------------
2486       subroutine check_vecgrad
2487       implicit real*8 (a-h,o-z)
2488       include 'DIMENSIONS'
2489       include 'COMMON.IOUNITS'
2490       include 'COMMON.GEO'
2491       include 'COMMON.VAR'
2492       include 'COMMON.LOCAL'
2493       include 'COMMON.CHAIN'
2494       include 'COMMON.VECTORS'
2495       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2496       dimension uyt(3,maxres),uzt(3,maxres)
2497       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2498       double precision delta /1.0d-7/
2499       call vec_and_deriv
2500 cd      do i=1,nres
2501 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2502 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2503 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2504 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2505 cd     &     (dc_norm(if90,i),if90=1,3)
2506 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2507 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2508 cd          write(iout,'(a)')
2509 cd      enddo
2510       do i=1,nres
2511         do j=1,2
2512           do k=1,3
2513             do l=1,3
2514               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2515               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2516             enddo
2517           enddo
2518         enddo
2519       enddo
2520       call vec_and_deriv
2521       do i=1,nres
2522         do j=1,3
2523           uyt(j,i)=uy(j,i)
2524           uzt(j,i)=uz(j,i)
2525         enddo
2526       enddo
2527       do i=1,nres
2528 cd        write (iout,*) 'i=',i
2529         do k=1,3
2530           erij(k)=dc_norm(k,i)
2531         enddo
2532         do j=1,3
2533           do k=1,3
2534             dc_norm(k,i)=erij(k)
2535           enddo
2536           dc_norm(j,i)=dc_norm(j,i)+delta
2537 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2538 c          do k=1,3
2539 c            dc_norm(k,i)=dc_norm(k,i)/fac
2540 c          enddo
2541 c          write (iout,*) (dc_norm(k,i),k=1,3)
2542 c          write (iout,*) (erij(k),k=1,3)
2543           call vec_and_deriv
2544           do k=1,3
2545             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2546             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2547             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2548             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2549           enddo
2550 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2551 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2552 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2553         enddo
2554         do k=1,3
2555           dc_norm(k,i)=erij(k)
2556         enddo
2557 cd        do k=1,3
2558 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2559 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2560 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2561 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2562 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2563 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2564 cd          write (iout,'(a)')
2565 cd        enddo
2566       enddo
2567       return
2568       end
2569 C--------------------------------------------------------------------------
2570       subroutine set_matrices
2571       implicit real*8 (a-h,o-z)
2572       include 'DIMENSIONS'
2573 #ifdef MPI
2574       include "mpif.h"
2575       include "COMMON.SETUP"
2576       integer IERR
2577       integer status(MPI_STATUS_SIZE)
2578 #endif
2579       include 'COMMON.IOUNITS'
2580       include 'COMMON.GEO'
2581       include 'COMMON.VAR'
2582       include 'COMMON.LOCAL'
2583       include 'COMMON.CHAIN'
2584       include 'COMMON.DERIV'
2585       include 'COMMON.INTERACT'
2586       include 'COMMON.CONTACTS'
2587       include 'COMMON.TORSION'
2588       include 'COMMON.VECTORS'
2589       include 'COMMON.FFIELD'
2590       double precision auxvec(2),auxmat(2,2)
2591 C
2592 C Compute the virtual-bond-torsional-angle dependent quantities needed
2593 C to calculate the el-loc multibody terms of various order.
2594 C
2595 #ifdef PARMAT
2596       do i=ivec_start+2,ivec_end+2
2597 #else
2598       do i=3,nres+1
2599 #endif
2600         if (i .lt. nres+1) then
2601           sin1=dsin(phi(i))
2602           cos1=dcos(phi(i))
2603           sintab(i-2)=sin1
2604           costab(i-2)=cos1
2605           obrot(1,i-2)=cos1
2606           obrot(2,i-2)=sin1
2607           sin2=dsin(2*phi(i))
2608           cos2=dcos(2*phi(i))
2609           sintab2(i-2)=sin2
2610           costab2(i-2)=cos2
2611           obrot2(1,i-2)=cos2
2612           obrot2(2,i-2)=sin2
2613           Ug(1,1,i-2)=-cos1
2614           Ug(1,2,i-2)=-sin1
2615           Ug(2,1,i-2)=-sin1
2616           Ug(2,2,i-2)= cos1
2617           Ug2(1,1,i-2)=-cos2
2618           Ug2(1,2,i-2)=-sin2
2619           Ug2(2,1,i-2)=-sin2
2620           Ug2(2,2,i-2)= cos2
2621         else
2622           costab(i-2)=1.0d0
2623           sintab(i-2)=0.0d0
2624           obrot(1,i-2)=1.0d0
2625           obrot(2,i-2)=0.0d0
2626           obrot2(1,i-2)=0.0d0
2627           obrot2(2,i-2)=0.0d0
2628           Ug(1,1,i-2)=1.0d0
2629           Ug(1,2,i-2)=0.0d0
2630           Ug(2,1,i-2)=0.0d0
2631           Ug(2,2,i-2)=1.0d0
2632           Ug2(1,1,i-2)=0.0d0
2633           Ug2(1,2,i-2)=0.0d0
2634           Ug2(2,1,i-2)=0.0d0
2635           Ug2(2,2,i-2)=0.0d0
2636         endif
2637         if (i .gt. 3 .and. i .lt. nres+1) then
2638           obrot_der(1,i-2)=-sin1
2639           obrot_der(2,i-2)= cos1
2640           Ugder(1,1,i-2)= sin1
2641           Ugder(1,2,i-2)=-cos1
2642           Ugder(2,1,i-2)=-cos1
2643           Ugder(2,2,i-2)=-sin1
2644           dwacos2=cos2+cos2
2645           dwasin2=sin2+sin2
2646           obrot2_der(1,i-2)=-dwasin2
2647           obrot2_der(2,i-2)= dwacos2
2648           Ug2der(1,1,i-2)= dwasin2
2649           Ug2der(1,2,i-2)=-dwacos2
2650           Ug2der(2,1,i-2)=-dwacos2
2651           Ug2der(2,2,i-2)=-dwasin2
2652         else
2653           obrot_der(1,i-2)=0.0d0
2654           obrot_der(2,i-2)=0.0d0
2655           Ugder(1,1,i-2)=0.0d0
2656           Ugder(1,2,i-2)=0.0d0
2657           Ugder(2,1,i-2)=0.0d0
2658           Ugder(2,2,i-2)=0.0d0
2659           obrot2_der(1,i-2)=0.0d0
2660           obrot2_der(2,i-2)=0.0d0
2661           Ug2der(1,1,i-2)=0.0d0
2662           Ug2der(1,2,i-2)=0.0d0
2663           Ug2der(2,1,i-2)=0.0d0
2664           Ug2der(2,2,i-2)=0.0d0
2665         endif
2666 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2667         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2668           iti = itortyp(itype(i-2))
2669         else
2670           iti=ntortyp+1
2671         endif
2672 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2673         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2674           iti1 = itortyp(itype(i-1))
2675         else
2676           iti1=ntortyp+1
2677         endif
2678 cd        write (iout,*) '*******i',i,' iti1',iti
2679 cd        write (iout,*) 'b1',b1(:,iti)
2680 cd        write (iout,*) 'b2',b2(:,iti)
2681 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2682 c        if (i .gt. iatel_s+2) then
2683         if (i .gt. nnt+2) then
2684           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2685           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2686           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2687      &    then
2688           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2689           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2690           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2691           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2692           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2693           endif
2694         else
2695           do k=1,2
2696             Ub2(k,i-2)=0.0d0
2697             Ctobr(k,i-2)=0.0d0
2698             Dtobr2(k,i-2)=0.0d0
2699             do l=1,2
2700               EUg(l,k,i-2)=0.0d0
2701               CUg(l,k,i-2)=0.0d0
2702               DUg(l,k,i-2)=0.0d0
2703               DtUg2(l,k,i-2)=0.0d0
2704             enddo
2705           enddo
2706         endif
2707         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2708         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2709         do k=1,2
2710           muder(k,i-2)=Ub2der(k,i-2)
2711         enddo
2712 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2713         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2714           iti1 = itortyp(itype(i-1))
2715         else
2716           iti1=ntortyp+1
2717         endif
2718         do k=1,2
2719           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2720         enddo
2721 cd        write (iout,*) 'mu ',mu(:,i-2)
2722 cd        write (iout,*) 'mu1',mu1(:,i-2)
2723 cd        write (iout,*) 'mu2',mu2(:,i-2)
2724         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2725      &  then
2726         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2727         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2728         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2729         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2730         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2731 C Vectors and matrices dependent on a single virtual-bond dihedral.
2732         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2733         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2734         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2735         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2736         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2737         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2738         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2739         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2740         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2741         endif
2742       enddo
2743 C Matrices dependent on two consecutive virtual-bond dihedrals.
2744 C The order of matrices is from left to right.
2745       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2746      &then
2747 c      do i=max0(ivec_start,2),ivec_end
2748       do i=2,nres-1
2749         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2750         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2751         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2752         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2753         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2754         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2755         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2756         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2757       enddo
2758       endif
2759 #if defined(MPI) && defined(PARMAT)
2760 #ifdef DEBUG
2761 c      if (fg_rank.eq.0) then
2762         write (iout,*) "Arrays UG and UGDER before GATHER"
2763         do i=1,nres-1
2764           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2765      &     ((ug(l,k,i),l=1,2),k=1,2),
2766      &     ((ugder(l,k,i),l=1,2),k=1,2)
2767         enddo
2768         write (iout,*) "Arrays UG2 and UG2DER"
2769         do i=1,nres-1
2770           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2771      &     ((ug2(l,k,i),l=1,2),k=1,2),
2772      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2773         enddo
2774         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2775         do i=1,nres-1
2776           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2777      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2778      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2779         enddo
2780         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2781         do i=1,nres-1
2782           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2783      &     costab(i),sintab(i),costab2(i),sintab2(i)
2784         enddo
2785         write (iout,*) "Array MUDER"
2786         do i=1,nres-1
2787           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2788         enddo
2789 c      endif
2790 #endif
2791       if (nfgtasks.gt.1) then
2792         time00=MPI_Wtime()
2793 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2794 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2795 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2796 #ifdef MATGATHER
2797         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2798      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2799      &   FG_COMM1,IERR)
2800         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2801      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2802      &   FG_COMM1,IERR)
2803         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2804      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2805      &   FG_COMM1,IERR)
2806         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2807      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2808      &   FG_COMM1,IERR)
2809         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2810      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2811      &   FG_COMM1,IERR)
2812         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2813      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2814      &   FG_COMM1,IERR)
2815         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2816      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2817      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2818         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2819      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2820      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2821         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2822      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2823      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2824         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2825      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2826      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2827         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2828      &  then
2829         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2830      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2831      &   FG_COMM1,IERR)
2832         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2833      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2834      &   FG_COMM1,IERR)
2835         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2836      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2837      &   FG_COMM1,IERR)
2838        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2839      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2840      &   FG_COMM1,IERR)
2841         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2842      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2843      &   FG_COMM1,IERR)
2844         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2845      &   ivec_count(fg_rank1),
2846      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2847      &   FG_COMM1,IERR)
2848         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2849      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2850      &   FG_COMM1,IERR)
2851         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2852      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2853      &   FG_COMM1,IERR)
2854         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2855      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2856      &   FG_COMM1,IERR)
2857         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2858      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2859      &   FG_COMM1,IERR)
2860         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2861      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2862      &   FG_COMM1,IERR)
2863         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2864      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2865      &   FG_COMM1,IERR)
2866         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2867      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2868      &   FG_COMM1,IERR)
2869         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2870      &   ivec_count(fg_rank1),
2871      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2872      &   FG_COMM1,IERR)
2873         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2874      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2875      &   FG_COMM1,IERR)
2876        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2877      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2878      &   FG_COMM1,IERR)
2879         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2880      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2881      &   FG_COMM1,IERR)
2882        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2883      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2884      &   FG_COMM1,IERR)
2885         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2886      &   ivec_count(fg_rank1),
2887      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2888      &   FG_COMM1,IERR)
2889         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2890      &   ivec_count(fg_rank1),
2891      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2892      &   FG_COMM1,IERR)
2893         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2894      &   ivec_count(fg_rank1),
2895      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2896      &   MPI_MAT2,FG_COMM1,IERR)
2897         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2898      &   ivec_count(fg_rank1),
2899      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2900      &   MPI_MAT2,FG_COMM1,IERR)
2901         endif
2902 #else
2903 c Passes matrix info through the ring
2904       isend=fg_rank1
2905       irecv=fg_rank1-1
2906       if (irecv.lt.0) irecv=nfgtasks1-1
2907       iprev=irecv
2908       inext=fg_rank1+1
2909       if (inext.ge.nfgtasks1) inext=0
2910       do i=1,nfgtasks1-1
2911 c        write (iout,*) "isend",isend," irecv",irecv
2912 c        call flush(iout)
2913         lensend=lentyp(isend)
2914         lenrecv=lentyp(irecv)
2915 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2916 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2917 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2918 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2919 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2920 c        write (iout,*) "Gather ROTAT1"
2921 c        call flush(iout)
2922 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2923 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2924 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2925 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2926 c        write (iout,*) "Gather ROTAT2"
2927 c        call flush(iout)
2928         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2929      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2930      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2931      &   iprev,4400+irecv,FG_COMM,status,IERR)
2932 c        write (iout,*) "Gather ROTAT_OLD"
2933 c        call flush(iout)
2934         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2935      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2936      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2937      &   iprev,5500+irecv,FG_COMM,status,IERR)
2938 c        write (iout,*) "Gather PRECOMP11"
2939 c        call flush(iout)
2940         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2941      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2942      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2943      &   iprev,6600+irecv,FG_COMM,status,IERR)
2944 c        write (iout,*) "Gather PRECOMP12"
2945 c        call flush(iout)
2946         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2947      &  then
2948         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2949      &   MPI_ROTAT2(lensend),inext,7700+isend,
2950      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2951      &   iprev,7700+irecv,FG_COMM,status,IERR)
2952 c        write (iout,*) "Gather PRECOMP21"
2953 c        call flush(iout)
2954         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2955      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2956      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2957      &   iprev,8800+irecv,FG_COMM,status,IERR)
2958 c        write (iout,*) "Gather PRECOMP22"
2959 c        call flush(iout)
2960         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2961      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2962      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2963      &   MPI_PRECOMP23(lenrecv),
2964      &   iprev,9900+irecv,FG_COMM,status,IERR)
2965 c        write (iout,*) "Gather PRECOMP23"
2966 c        call flush(iout)
2967         endif
2968         isend=irecv
2969         irecv=irecv-1
2970         if (irecv.lt.0) irecv=nfgtasks1-1
2971       enddo
2972 #endif
2973         time_gather=time_gather+MPI_Wtime()-time00
2974       endif
2975 #ifdef DEBUG
2976 c      if (fg_rank.eq.0) then
2977         write (iout,*) "Arrays UG and UGDER"
2978         do i=1,nres-1
2979           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2980      &     ((ug(l,k,i),l=1,2),k=1,2),
2981      &     ((ugder(l,k,i),l=1,2),k=1,2)
2982         enddo
2983         write (iout,*) "Arrays UG2 and UG2DER"
2984         do i=1,nres-1
2985           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2986      &     ((ug2(l,k,i),l=1,2),k=1,2),
2987      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2988         enddo
2989         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2990         do i=1,nres-1
2991           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2992      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2993      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2994         enddo
2995         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2996         do i=1,nres-1
2997           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2998      &     costab(i),sintab(i),costab2(i),sintab2(i)
2999         enddo
3000         write (iout,*) "Array MUDER"
3001         do i=1,nres-1
3002           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3003         enddo
3004 c      endif
3005 #endif
3006 #endif
3007 cd      do i=1,nres
3008 cd        iti = itortyp(itype(i))
3009 cd        write (iout,*) i
3010 cd        do j=1,2
3011 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3012 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3013 cd        enddo
3014 cd      enddo
3015       return
3016       end
3017 C--------------------------------------------------------------------------
3018       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3019 C
3020 C This subroutine calculates the average interaction energy and its gradient
3021 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3022 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3023 C The potential depends both on the distance of peptide-group centers and on
3024 C the orientation of the CA-CA virtual bonds.
3025 C
3026       implicit real*8 (a-h,o-z)
3027 #ifdef MPI
3028       include 'mpif.h'
3029 #endif
3030       include 'DIMENSIONS'
3031       include 'COMMON.CONTROL'
3032       include 'COMMON.SETUP'
3033       include 'COMMON.IOUNITS'
3034       include 'COMMON.GEO'
3035       include 'COMMON.VAR'
3036       include 'COMMON.LOCAL'
3037       include 'COMMON.CHAIN'
3038       include 'COMMON.DERIV'
3039       include 'COMMON.INTERACT'
3040       include 'COMMON.CONTACTS'
3041       include 'COMMON.TORSION'
3042       include 'COMMON.VECTORS'
3043       include 'COMMON.FFIELD'
3044       include 'COMMON.TIME1'
3045       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3046      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3047       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3048      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3049       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3050      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3051      &    num_conti,j1,j2
3052 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3053 #ifdef MOMENT
3054       double precision scal_el /1.0d0/
3055 #else
3056       double precision scal_el /0.5d0/
3057 #endif
3058 C 12/13/98
3059 C 13-go grudnia roku pamietnego...
3060       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3061      &                   0.0d0,1.0d0,0.0d0,
3062      &                   0.0d0,0.0d0,1.0d0/
3063 cd      write(iout,*) 'In EELEC'
3064 cd      do i=1,nloctyp
3065 cd        write(iout,*) 'Type',i
3066 cd        write(iout,*) 'B1',B1(:,i)
3067 cd        write(iout,*) 'B2',B2(:,i)
3068 cd        write(iout,*) 'CC',CC(:,:,i)
3069 cd        write(iout,*) 'DD',DD(:,:,i)
3070 cd        write(iout,*) 'EE',EE(:,:,i)
3071 cd      enddo
3072 cd      call check_vecgrad
3073 cd      stop
3074       if (icheckgrad.eq.1) then
3075         do i=1,nres-1
3076           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3077           do k=1,3
3078             dc_norm(k,i)=dc(k,i)*fac
3079           enddo
3080 c          write (iout,*) 'i',i,' fac',fac
3081         enddo
3082       endif
3083       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3084      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3085      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3086 c        call vec_and_deriv
3087 #ifdef TIMING
3088         time01=MPI_Wtime()
3089 #endif
3090         call set_matrices
3091 #ifdef TIMING
3092         time_mat=time_mat+MPI_Wtime()-time01
3093 #endif
3094       endif
3095 cd      do i=1,nres-1
3096 cd        write (iout,*) 'i=',i
3097 cd        do k=1,3
3098 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3099 cd        enddo
3100 cd        do k=1,3
3101 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3102 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3103 cd        enddo
3104 cd      enddo
3105       t_eelecij=0.0d0
3106       ees=0.0D0
3107       evdw1=0.0D0
3108       eel_loc=0.0d0
3109       eello_turn3=0.0d0
3110       eello_turn4=0.0d0
3111       ind=0
3112       do i=1,nres
3113         num_cont_hb(i)=0
3114       enddo
3115 cd      print '(a)','Enter EELEC'
3116 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3117       do i=1,nres
3118         gel_loc_loc(i)=0.0d0
3119         gcorr_loc(i)=0.0d0
3120       enddo
3121 c
3122 c
3123 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3124 C
3125 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3126 C
3127       do i=iturn3_start,iturn3_end
3128         dxi=dc(1,i)
3129         dyi=dc(2,i)
3130         dzi=dc(3,i)
3131         dx_normi=dc_norm(1,i)
3132         dy_normi=dc_norm(2,i)
3133         dz_normi=dc_norm(3,i)
3134         xmedi=c(1,i)+0.5d0*dxi
3135         ymedi=c(2,i)+0.5d0*dyi
3136         zmedi=c(3,i)+0.5d0*dzi
3137         num_conti=0
3138         call eelecij(i,i+2,ees,evdw1,eel_loc)
3139         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3140         num_cont_hb(i)=num_conti
3141       enddo
3142       do i=iturn4_start,iturn4_end
3143         dxi=dc(1,i)
3144         dyi=dc(2,i)
3145         dzi=dc(3,i)
3146         dx_normi=dc_norm(1,i)
3147         dy_normi=dc_norm(2,i)
3148         dz_normi=dc_norm(3,i)
3149         xmedi=c(1,i)+0.5d0*dxi
3150         ymedi=c(2,i)+0.5d0*dyi
3151         zmedi=c(3,i)+0.5d0*dzi
3152         num_conti=num_cont_hb(i)
3153         call eelecij(i,i+3,ees,evdw1,eel_loc)
3154         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3155         num_cont_hb(i)=num_conti
3156       enddo   ! i
3157 c
3158 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3159 c
3160       do i=iatel_s,iatel_e
3161         dxi=dc(1,i)
3162         dyi=dc(2,i)
3163         dzi=dc(3,i)
3164         dx_normi=dc_norm(1,i)
3165         dy_normi=dc_norm(2,i)
3166         dz_normi=dc_norm(3,i)
3167         xmedi=c(1,i)+0.5d0*dxi
3168         ymedi=c(2,i)+0.5d0*dyi
3169         zmedi=c(3,i)+0.5d0*dzi
3170 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3171         num_conti=num_cont_hb(i)
3172         do j=ielstart(i),ielend(i)
3173           call eelecij(i,j,ees,evdw1,eel_loc)
3174         enddo ! j
3175         num_cont_hb(i)=num_conti
3176       enddo   ! i
3177 c      write (iout,*) "Number of loop steps in EELEC:",ind
3178 cd      do i=1,nres
3179 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3180 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3181 cd      enddo
3182 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3183 ccc      eel_loc=eel_loc+eello_turn3
3184 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3185       return
3186       end
3187 C-------------------------------------------------------------------------------
3188       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3189       implicit real*8 (a-h,o-z)
3190       include 'DIMENSIONS'
3191 #ifdef MPI
3192       include "mpif.h"
3193 #endif
3194       include 'COMMON.CONTROL'
3195       include 'COMMON.IOUNITS'
3196       include 'COMMON.GEO'
3197       include 'COMMON.VAR'
3198       include 'COMMON.LOCAL'
3199       include 'COMMON.CHAIN'
3200       include 'COMMON.DERIV'
3201       include 'COMMON.INTERACT'
3202       include 'COMMON.CONTACTS'
3203       include 'COMMON.TORSION'
3204       include 'COMMON.VECTORS'
3205       include 'COMMON.FFIELD'
3206       include 'COMMON.TIME1'
3207       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3208      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3209       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3210      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3211       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3212      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3213      &    num_conti,j1,j2
3214 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3215 #ifdef MOMENT
3216       double precision scal_el /1.0d0/
3217 #else
3218       double precision scal_el /0.5d0/
3219 #endif
3220 C 12/13/98
3221 C 13-go grudnia roku pamietnego...
3222       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3223      &                   0.0d0,1.0d0,0.0d0,
3224      &                   0.0d0,0.0d0,1.0d0/
3225 c          time00=MPI_Wtime()
3226 cd      write (iout,*) "eelecij",i,j
3227 c          ind=ind+1
3228           iteli=itel(i)
3229           itelj=itel(j)
3230           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3231           aaa=app(iteli,itelj)
3232           bbb=bpp(iteli,itelj)
3233           ael6i=ael6(iteli,itelj)
3234           ael3i=ael3(iteli,itelj)
3235           dxj=dc(1,j)
3236           dyj=dc(2,j)
3237           dzj=dc(3,j)
3238           dx_normj=dc_norm(1,j)
3239           dy_normj=dc_norm(2,j)
3240           dz_normj=dc_norm(3,j)
3241           xj=c(1,j)+0.5D0*dxj-xmedi
3242           yj=c(2,j)+0.5D0*dyj-ymedi
3243           zj=c(3,j)+0.5D0*dzj-zmedi
3244           rij=xj*xj+yj*yj+zj*zj
3245           rrmij=1.0D0/rij
3246           rij=dsqrt(rij)
3247           rmij=1.0D0/rij
3248           r3ij=rrmij*rmij
3249           r6ij=r3ij*r3ij
3250           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3251           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3252           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3253           fac=cosa-3.0D0*cosb*cosg
3254           ev1=aaa*r6ij*r6ij
3255 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3256           if (j.eq.i+2) ev1=scal_el*ev1
3257           ev2=bbb*r6ij
3258           fac3=ael6i*r6ij
3259           fac4=ael3i*r3ij
3260           evdwij=ev1+ev2
3261           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3262           el2=fac4*fac
3263           eesij=el1+el2
3264 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3265           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3266           ees=ees+eesij
3267           evdw1=evdw1+evdwij
3268 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3269 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3270 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3271 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3272
3273           if (energy_dec) then
3274               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3275               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3276           endif
3277
3278 C
3279 C Calculate contributions to the Cartesian gradient.
3280 C
3281 #ifdef SPLITELE
3282           facvdw=-6*rrmij*(ev1+evdwij)
3283           facel=-3*rrmij*(el1+eesij)
3284           fac1=fac
3285           erij(1)=xj*rmij
3286           erij(2)=yj*rmij
3287           erij(3)=zj*rmij
3288 *
3289 * Radial derivatives. First process both termini of the fragment (i,j)
3290 *
3291           ggg(1)=facel*xj
3292           ggg(2)=facel*yj
3293           ggg(3)=facel*zj
3294 c          do k=1,3
3295 c            ghalf=0.5D0*ggg(k)
3296 c            gelc(k,i)=gelc(k,i)+ghalf
3297 c            gelc(k,j)=gelc(k,j)+ghalf
3298 c          enddo
3299 c 9/28/08 AL Gradient compotents will be summed only at the end
3300           do k=1,3
3301             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3302             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3303           enddo
3304 *
3305 * Loop over residues i+1 thru j-1.
3306 *
3307 cgrad          do k=i+1,j-1
3308 cgrad            do l=1,3
3309 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3310 cgrad            enddo
3311 cgrad          enddo
3312           ggg(1)=facvdw*xj
3313           ggg(2)=facvdw*yj
3314           ggg(3)=facvdw*zj
3315 c          do k=1,3
3316 c            ghalf=0.5D0*ggg(k)
3317 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3318 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3319 c          enddo
3320 c 9/28/08 AL Gradient compotents will be summed only at the end
3321           do k=1,3
3322             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3323             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3324           enddo
3325 *
3326 * Loop over residues i+1 thru j-1.
3327 *
3328 cgrad          do k=i+1,j-1
3329 cgrad            do l=1,3
3330 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3331 cgrad            enddo
3332 cgrad          enddo
3333 #else
3334           facvdw=ev1+evdwij
3335           facel=el1+eesij
3336           fac1=fac
3337           fac=-3*rrmij*(facvdw+facvdw+facel)
3338           erij(1)=xj*rmij
3339           erij(2)=yj*rmij
3340           erij(3)=zj*rmij
3341 *
3342 * Radial derivatives. First process both termini of the fragment (i,j)
3343 *
3344           ggg(1)=fac*xj
3345           ggg(2)=fac*yj
3346           ggg(3)=fac*zj
3347 c          do k=1,3
3348 c            ghalf=0.5D0*ggg(k)
3349 c            gelc(k,i)=gelc(k,i)+ghalf
3350 c            gelc(k,j)=gelc(k,j)+ghalf
3351 c          enddo
3352 c 9/28/08 AL Gradient compotents will be summed only at the end
3353           do k=1,3
3354             gelc_long(k,j)=gelc(k,j)+ggg(k)
3355             gelc_long(k,i)=gelc(k,i)-ggg(k)
3356           enddo
3357 *
3358 * Loop over residues i+1 thru j-1.
3359 *
3360 cgrad          do k=i+1,j-1
3361 cgrad            do l=1,3
3362 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3363 cgrad            enddo
3364 cgrad          enddo
3365 c 9/28/08 AL Gradient compotents will be summed only at the end
3366           ggg(1)=facvdw*xj
3367           ggg(2)=facvdw*yj
3368           ggg(3)=facvdw*zj
3369           do k=1,3
3370             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3371             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3372           enddo
3373 #endif
3374 *
3375 * Angular part
3376 *
3377           ecosa=2.0D0*fac3*fac1+fac4
3378           fac4=-3.0D0*fac4
3379           fac3=-6.0D0*fac3
3380           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3381           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3382           do k=1,3
3383             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3384             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3385           enddo
3386 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3387 cd   &          (dcosg(k),k=1,3)
3388           do k=1,3
3389             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3390           enddo
3391 c          do k=1,3
3392 c            ghalf=0.5D0*ggg(k)
3393 c            gelc(k,i)=gelc(k,i)+ghalf
3394 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3395 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3396 c            gelc(k,j)=gelc(k,j)+ghalf
3397 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3398 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3399 c          enddo
3400 cgrad          do k=i+1,j-1
3401 cgrad            do l=1,3
3402 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3403 cgrad            enddo
3404 cgrad          enddo
3405           do k=1,3
3406             gelc(k,i)=gelc(k,i)
3407      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3408      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3409             gelc(k,j)=gelc(k,j)
3410      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3411      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3412             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3413             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3414           enddo
3415           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3416      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3417      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3418 C
3419 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3420 C   energy of a peptide unit is assumed in the form of a second-order
3421 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3422 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3423 C   are computed for EVERY pair of non-contiguous peptide groups.
3424 C
3425           if (j.lt.nres-1) then
3426             j1=j+1
3427             j2=j-1
3428           else
3429             j1=j-1
3430             j2=j-2
3431           endif
3432           kkk=0
3433           do k=1,2
3434             do l=1,2
3435               kkk=kkk+1
3436               muij(kkk)=mu(k,i)*mu(l,j)
3437             enddo
3438           enddo
3439 cd         write (iout,*) 'EELEC: i',i,' j',j
3440 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3441 cd          write(iout,*) 'muij',muij
3442           ury=scalar(uy(1,i),erij)
3443           urz=scalar(uz(1,i),erij)
3444           vry=scalar(uy(1,j),erij)
3445           vrz=scalar(uz(1,j),erij)
3446           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3447           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3448           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3449           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3450           fac=dsqrt(-ael6i)*r3ij
3451           a22=a22*fac
3452           a23=a23*fac
3453           a32=a32*fac
3454           a33=a33*fac
3455 cd          write (iout,'(4i5,4f10.5)')
3456 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3457 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3458 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3459 cd     &      uy(:,j),uz(:,j)
3460 cd          write (iout,'(4f10.5)')
3461 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3462 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3463 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3464 cd           write (iout,'(9f10.5/)')
3465 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3466 C Derivatives of the elements of A in virtual-bond vectors
3467           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3468           do k=1,3
3469             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3470             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3471             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3472             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3473             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3474             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3475             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3476             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3477             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3478             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3479             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3480             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3481           enddo
3482 C Compute radial contributions to the gradient
3483           facr=-3.0d0*rrmij
3484           a22der=a22*facr
3485           a23der=a23*facr
3486           a32der=a32*facr
3487           a33der=a33*facr
3488           agg(1,1)=a22der*xj
3489           agg(2,1)=a22der*yj
3490           agg(3,1)=a22der*zj
3491           agg(1,2)=a23der*xj
3492           agg(2,2)=a23der*yj
3493           agg(3,2)=a23der*zj
3494           agg(1,3)=a32der*xj
3495           agg(2,3)=a32der*yj
3496           agg(3,3)=a32der*zj
3497           agg(1,4)=a33der*xj
3498           agg(2,4)=a33der*yj
3499           agg(3,4)=a33der*zj
3500 C Add the contributions coming from er
3501           fac3=-3.0d0*fac
3502           do k=1,3
3503             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3504             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3505             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3506             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3507           enddo
3508           do k=1,3
3509 C Derivatives in DC(i)
3510 cgrad            ghalf1=0.5d0*agg(k,1)
3511 cgrad            ghalf2=0.5d0*agg(k,2)
3512 cgrad            ghalf3=0.5d0*agg(k,3)
3513 cgrad            ghalf4=0.5d0*agg(k,4)
3514             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3515      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3516             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3517      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3518             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3519      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3520             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3521      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3522 C Derivatives in DC(i+1)
3523             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3524      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3525             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3526      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3527             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3528      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3529             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3530      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3531 C Derivatives in DC(j)
3532             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3533      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3534             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3535      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3536             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3537      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3538             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3539      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3540 C Derivatives in DC(j+1) or DC(nres-1)
3541             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3542      &      -3.0d0*vryg(k,3)*ury)
3543             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3544      &      -3.0d0*vrzg(k,3)*ury)
3545             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3546      &      -3.0d0*vryg(k,3)*urz)
3547             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3548      &      -3.0d0*vrzg(k,3)*urz)
3549 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3550 cgrad              do l=1,4
3551 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3552 cgrad              enddo
3553 cgrad            endif
3554           enddo
3555           acipa(1,1)=a22
3556           acipa(1,2)=a23
3557           acipa(2,1)=a32
3558           acipa(2,2)=a33
3559           a22=-a22
3560           a23=-a23
3561           do l=1,2
3562             do k=1,3
3563               agg(k,l)=-agg(k,l)
3564               aggi(k,l)=-aggi(k,l)
3565               aggi1(k,l)=-aggi1(k,l)
3566               aggj(k,l)=-aggj(k,l)
3567               aggj1(k,l)=-aggj1(k,l)
3568             enddo
3569           enddo
3570           if (j.lt.nres-1) then
3571             a22=-a22
3572             a32=-a32
3573             do l=1,3,2
3574               do k=1,3
3575                 agg(k,l)=-agg(k,l)
3576                 aggi(k,l)=-aggi(k,l)
3577                 aggi1(k,l)=-aggi1(k,l)
3578                 aggj(k,l)=-aggj(k,l)
3579                 aggj1(k,l)=-aggj1(k,l)
3580               enddo
3581             enddo
3582           else
3583             a22=-a22
3584             a23=-a23
3585             a32=-a32
3586             a33=-a33
3587             do l=1,4
3588               do k=1,3
3589                 agg(k,l)=-agg(k,l)
3590                 aggi(k,l)=-aggi(k,l)
3591                 aggi1(k,l)=-aggi1(k,l)
3592                 aggj(k,l)=-aggj(k,l)
3593                 aggj1(k,l)=-aggj1(k,l)
3594               enddo
3595             enddo
3596           endif
3597           ENDIF ! WCORR
3598           IF (wel_loc.gt.0.0d0) THEN
3599 C Contribution to the local-electrostatic energy coming from the i-j pair
3600           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3601      &     +a33*muij(4)
3602 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3603
3604           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3605      &            'eelloc',i,j,eel_loc_ij
3606
3607           eel_loc=eel_loc+eel_loc_ij
3608 C Partial derivatives in virtual-bond dihedral angles gamma
3609           if (i.gt.1)
3610      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3611      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3612      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3613           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3614      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3615      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3616 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3617           do l=1,3
3618             ggg(l)=agg(l,1)*muij(1)+
3619      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3620             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3621             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3622 cgrad            ghalf=0.5d0*ggg(l)
3623 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3624 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3625           enddo
3626 cgrad          do k=i+1,j2
3627 cgrad            do l=1,3
3628 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3629 cgrad            enddo
3630 cgrad          enddo
3631 C Remaining derivatives of eello
3632           do l=1,3
3633             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3634      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3635             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3636      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3637             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3638      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3639             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3640      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3641           enddo
3642           ENDIF
3643 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3644 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3645           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3646      &       .and. num_conti.le.maxconts) then
3647 c            write (iout,*) i,j," entered corr"
3648 C
3649 C Calculate the contact function. The ith column of the array JCONT will
3650 C contain the numbers of atoms that make contacts with the atom I (of numbers
3651 C greater than I). The arrays FACONT and GACONT will contain the values of
3652 C the contact function and its derivative.
3653 c           r0ij=1.02D0*rpp(iteli,itelj)
3654 c           r0ij=1.11D0*rpp(iteli,itelj)
3655             r0ij=2.20D0*rpp(iteli,itelj)
3656 c           r0ij=1.55D0*rpp(iteli,itelj)
3657             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3658             if (fcont.gt.0.0D0) then
3659               num_conti=num_conti+1
3660               if (num_conti.gt.maxconts) then
3661                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3662      &                         ' will skip next contacts for this conf.'
3663               else
3664                 jcont_hb(num_conti,i)=j
3665 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3666 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3667                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3668      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3669 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3670 C  terms.
3671                 d_cont(num_conti,i)=rij
3672 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3673 C     --- Electrostatic-interaction matrix ---
3674                 a_chuj(1,1,num_conti,i)=a22
3675                 a_chuj(1,2,num_conti,i)=a23
3676                 a_chuj(2,1,num_conti,i)=a32
3677                 a_chuj(2,2,num_conti,i)=a33
3678 C     --- Gradient of rij
3679                 do kkk=1,3
3680                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3681                 enddo
3682                 kkll=0
3683                 do k=1,2
3684                   do l=1,2
3685                     kkll=kkll+1
3686                     do m=1,3
3687                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3688                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3689                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3690                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3691                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3692                     enddo
3693                   enddo
3694                 enddo
3695                 ENDIF
3696                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3697 C Calculate contact energies
3698                 cosa4=4.0D0*cosa
3699                 wij=cosa-3.0D0*cosb*cosg
3700                 cosbg1=cosb+cosg
3701                 cosbg2=cosb-cosg
3702 c               fac3=dsqrt(-ael6i)/r0ij**3
3703                 fac3=dsqrt(-ael6i)*r3ij
3704 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3705                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3706                 if (ees0tmp.gt.0) then
3707                   ees0pij=dsqrt(ees0tmp)
3708                 else
3709                   ees0pij=0
3710                 endif
3711 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3712                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3713                 if (ees0tmp.gt.0) then
3714                   ees0mij=dsqrt(ees0tmp)
3715                 else
3716                   ees0mij=0
3717                 endif
3718 c               ees0mij=0.0D0
3719                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3720                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3721 C Diagnostics. Comment out or remove after debugging!
3722 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3723 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3724 c               ees0m(num_conti,i)=0.0D0
3725 C End diagnostics.
3726 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3727 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3728 C Angular derivatives of the contact function
3729                 ees0pij1=fac3/ees0pij
3730                 ees0mij1=fac3/ees0mij
3731                 fac3p=-3.0D0*fac3*rrmij
3732                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3733                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3734 c               ees0mij1=0.0D0
3735                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3736                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3737                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3738                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3739                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3740                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3741                 ecosap=ecosa1+ecosa2
3742                 ecosbp=ecosb1+ecosb2
3743                 ecosgp=ecosg1+ecosg2
3744                 ecosam=ecosa1-ecosa2
3745                 ecosbm=ecosb1-ecosb2
3746                 ecosgm=ecosg1-ecosg2
3747 C Diagnostics
3748 c               ecosap=ecosa1
3749 c               ecosbp=ecosb1
3750 c               ecosgp=ecosg1
3751 c               ecosam=0.0D0
3752 c               ecosbm=0.0D0
3753 c               ecosgm=0.0D0
3754 C End diagnostics
3755                 facont_hb(num_conti,i)=fcont
3756                 fprimcont=fprimcont/rij
3757 cd              facont_hb(num_conti,i)=1.0D0
3758 C Following line is for diagnostics.
3759 cd              fprimcont=0.0D0
3760                 do k=1,3
3761                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3762                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3763                 enddo
3764                 do k=1,3
3765                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3766                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3767                 enddo
3768                 gggp(1)=gggp(1)+ees0pijp*xj
3769                 gggp(2)=gggp(2)+ees0pijp*yj
3770                 gggp(3)=gggp(3)+ees0pijp*zj
3771                 gggm(1)=gggm(1)+ees0mijp*xj
3772                 gggm(2)=gggm(2)+ees0mijp*yj
3773                 gggm(3)=gggm(3)+ees0mijp*zj
3774 C Derivatives due to the contact function
3775                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3776                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3777                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3778                 do k=1,3
3779 c
3780 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3781 c          following the change of gradient-summation algorithm.
3782 c
3783 cgrad                  ghalfp=0.5D0*gggp(k)
3784 cgrad                  ghalfm=0.5D0*gggm(k)
3785                   gacontp_hb1(k,num_conti,i)=!ghalfp
3786      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3787      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3788                   gacontp_hb2(k,num_conti,i)=!ghalfp
3789      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3790      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3791                   gacontp_hb3(k,num_conti,i)=gggp(k)
3792                   gacontm_hb1(k,num_conti,i)=!ghalfm
3793      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3794      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3795                   gacontm_hb2(k,num_conti,i)=!ghalfm
3796      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3797      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3798                   gacontm_hb3(k,num_conti,i)=gggm(k)
3799                 enddo
3800 C Diagnostics. Comment out or remove after debugging!
3801 cdiag           do k=1,3
3802 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3803 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3804 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3805 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3806 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3807 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3808 cdiag           enddo
3809               ENDIF ! wcorr
3810               endif  ! num_conti.le.maxconts
3811             endif  ! fcont.gt.0
3812           endif    ! j.gt.i+1
3813           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3814             do k=1,4
3815               do l=1,3
3816                 ghalf=0.5d0*agg(l,k)
3817                 aggi(l,k)=aggi(l,k)+ghalf
3818                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3819                 aggj(l,k)=aggj(l,k)+ghalf
3820               enddo
3821             enddo
3822             if (j.eq.nres-1 .and. i.lt.j-2) then
3823               do k=1,4
3824                 do l=1,3
3825                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3826                 enddo
3827               enddo
3828             endif
3829           endif
3830 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3831       return
3832       end
3833 C-----------------------------------------------------------------------------
3834       subroutine eturn3(i,eello_turn3)
3835 C Third- and fourth-order contributions from turns
3836       implicit real*8 (a-h,o-z)
3837       include 'DIMENSIONS'
3838       include 'COMMON.IOUNITS'
3839       include 'COMMON.GEO'
3840       include 'COMMON.VAR'
3841       include 'COMMON.LOCAL'
3842       include 'COMMON.CHAIN'
3843       include 'COMMON.DERIV'
3844       include 'COMMON.INTERACT'
3845       include 'COMMON.CONTACTS'
3846       include 'COMMON.TORSION'
3847       include 'COMMON.VECTORS'
3848       include 'COMMON.FFIELD'
3849       include 'COMMON.CONTROL'
3850       dimension ggg(3)
3851       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3852      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3853      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3854       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3855      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3856       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3857      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3858      &    num_conti,j1,j2
3859       j=i+2
3860 c      write (iout,*) "eturn3",i,j,j1,j2
3861       a_temp(1,1)=a22
3862       a_temp(1,2)=a23
3863       a_temp(2,1)=a32
3864       a_temp(2,2)=a33
3865 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3866 C
3867 C               Third-order contributions
3868 C
3869 C                 (i+2)o----(i+3)
3870 C                      | |
3871 C                      | |
3872 C                 (i+1)o----i
3873 C
3874 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3875 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3876         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3877         call transpose2(auxmat(1,1),auxmat1(1,1))
3878         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3879         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3880         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3881      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3882 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3883 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3884 cd     &    ' eello_turn3_num',4*eello_turn3_num
3885 C Derivatives in gamma(i)
3886         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3887         call transpose2(auxmat2(1,1),auxmat3(1,1))
3888         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3889         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3890 C Derivatives in gamma(i+1)
3891         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3892         call transpose2(auxmat2(1,1),auxmat3(1,1))
3893         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3894         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3895      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3896 C Cartesian derivatives
3897         do l=1,3
3898 c            ghalf1=0.5d0*agg(l,1)
3899 c            ghalf2=0.5d0*agg(l,2)
3900 c            ghalf3=0.5d0*agg(l,3)
3901 c            ghalf4=0.5d0*agg(l,4)
3902           a_temp(1,1)=aggi(l,1)!+ghalf1
3903           a_temp(1,2)=aggi(l,2)!+ghalf2
3904           a_temp(2,1)=aggi(l,3)!+ghalf3
3905           a_temp(2,2)=aggi(l,4)!+ghalf4
3906           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3907           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3908      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3909           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3910           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3911           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3912           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3913           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3914           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3915      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3916           a_temp(1,1)=aggj(l,1)!+ghalf1
3917           a_temp(1,2)=aggj(l,2)!+ghalf2
3918           a_temp(2,1)=aggj(l,3)!+ghalf3
3919           a_temp(2,2)=aggj(l,4)!+ghalf4
3920           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3921           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3922      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3923           a_temp(1,1)=aggj1(l,1)
3924           a_temp(1,2)=aggj1(l,2)
3925           a_temp(2,1)=aggj1(l,3)
3926           a_temp(2,2)=aggj1(l,4)
3927           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3928           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3929      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3930         enddo
3931       return
3932       end
3933 C-------------------------------------------------------------------------------
3934       subroutine eturn4(i,eello_turn4)
3935 C Third- and fourth-order contributions from turns
3936       implicit real*8 (a-h,o-z)
3937       include 'DIMENSIONS'
3938       include 'COMMON.IOUNITS'
3939       include 'COMMON.GEO'
3940       include 'COMMON.VAR'
3941       include 'COMMON.LOCAL'
3942       include 'COMMON.CHAIN'
3943       include 'COMMON.DERIV'
3944       include 'COMMON.INTERACT'
3945       include 'COMMON.CONTACTS'
3946       include 'COMMON.TORSION'
3947       include 'COMMON.VECTORS'
3948       include 'COMMON.FFIELD'
3949       include 'COMMON.CONTROL'
3950       dimension ggg(3)
3951       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3952      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3953      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3954       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3955      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3956       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3957      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3958      &    num_conti,j1,j2
3959       j=i+3
3960 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3961 C
3962 C               Fourth-order contributions
3963 C
3964 C                 (i+3)o----(i+4)
3965 C                     /  |
3966 C               (i+2)o   |
3967 C                     \  |
3968 C                 (i+1)o----i
3969 C
3970 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3971 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3972 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3973         a_temp(1,1)=a22
3974         a_temp(1,2)=a23
3975         a_temp(2,1)=a32
3976         a_temp(2,2)=a33
3977         iti1=itortyp(itype(i+1))
3978         iti2=itortyp(itype(i+2))
3979         iti3=itortyp(itype(i+3))
3980 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3981         call transpose2(EUg(1,1,i+1),e1t(1,1))
3982         call transpose2(Eug(1,1,i+2),e2t(1,1))
3983         call transpose2(Eug(1,1,i+3),e3t(1,1))
3984         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3985         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3986         s1=scalar2(b1(1,iti2),auxvec(1))
3987         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3988         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3989         s2=scalar2(b1(1,iti1),auxvec(1))
3990         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3991         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3992         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3993         eello_turn4=eello_turn4-(s1+s2+s3)
3994         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3995      &      'eturn4',i,j,-(s1+s2+s3)
3996 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3997 cd     &    ' eello_turn4_num',8*eello_turn4_num
3998 C Derivatives in gamma(i)
3999         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4000         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4001         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4002         s1=scalar2(b1(1,iti2),auxvec(1))
4003         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4004         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4005         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4006 C Derivatives in gamma(i+1)
4007         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4008         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4009         s2=scalar2(b1(1,iti1),auxvec(1))
4010         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4011         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4012         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4013         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4014 C Derivatives in gamma(i+2)
4015         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4016         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4017         s1=scalar2(b1(1,iti2),auxvec(1))
4018         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4019         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4020         s2=scalar2(b1(1,iti1),auxvec(1))
4021         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4022         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4023         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4024         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4025 C Cartesian derivatives
4026 C Derivatives of this turn contributions in DC(i+2)
4027         if (j.lt.nres-1) then
4028           do l=1,3
4029             a_temp(1,1)=agg(l,1)
4030             a_temp(1,2)=agg(l,2)
4031             a_temp(2,1)=agg(l,3)
4032             a_temp(2,2)=agg(l,4)
4033             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4034             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4035             s1=scalar2(b1(1,iti2),auxvec(1))
4036             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4037             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4038             s2=scalar2(b1(1,iti1),auxvec(1))
4039             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4040             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4041             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4042             ggg(l)=-(s1+s2+s3)
4043             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4044           enddo
4045         endif
4046 C Remaining derivatives of this turn contribution
4047         do l=1,3
4048           a_temp(1,1)=aggi(l,1)
4049           a_temp(1,2)=aggi(l,2)
4050           a_temp(2,1)=aggi(l,3)
4051           a_temp(2,2)=aggi(l,4)
4052           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4053           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4054           s1=scalar2(b1(1,iti2),auxvec(1))
4055           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4056           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4057           s2=scalar2(b1(1,iti1),auxvec(1))
4058           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4059           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4060           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4061           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4062           a_temp(1,1)=aggi1(l,1)
4063           a_temp(1,2)=aggi1(l,2)
4064           a_temp(2,1)=aggi1(l,3)
4065           a_temp(2,2)=aggi1(l,4)
4066           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4067           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4068           s1=scalar2(b1(1,iti2),auxvec(1))
4069           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4070           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4071           s2=scalar2(b1(1,iti1),auxvec(1))
4072           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4073           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4074           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4075           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4076           a_temp(1,1)=aggj(l,1)
4077           a_temp(1,2)=aggj(l,2)
4078           a_temp(2,1)=aggj(l,3)
4079           a_temp(2,2)=aggj(l,4)
4080           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4081           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4082           s1=scalar2(b1(1,iti2),auxvec(1))
4083           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4084           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4085           s2=scalar2(b1(1,iti1),auxvec(1))
4086           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4087           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4088           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4089           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4090           a_temp(1,1)=aggj1(l,1)
4091           a_temp(1,2)=aggj1(l,2)
4092           a_temp(2,1)=aggj1(l,3)
4093           a_temp(2,2)=aggj1(l,4)
4094           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4095           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4096           s1=scalar2(b1(1,iti2),auxvec(1))
4097           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4098           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4099           s2=scalar2(b1(1,iti1),auxvec(1))
4100           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4101           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4102           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4103 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4104           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4105         enddo
4106       return
4107       end
4108 C-----------------------------------------------------------------------------
4109       subroutine vecpr(u,v,w)
4110       implicit real*8(a-h,o-z)
4111       dimension u(3),v(3),w(3)
4112       w(1)=u(2)*v(3)-u(3)*v(2)
4113       w(2)=-u(1)*v(3)+u(3)*v(1)
4114       w(3)=u(1)*v(2)-u(2)*v(1)
4115       return
4116       end
4117 C-----------------------------------------------------------------------------
4118       subroutine unormderiv(u,ugrad,unorm,ungrad)
4119 C This subroutine computes the derivatives of a normalized vector u, given
4120 C the derivatives computed without normalization conditions, ugrad. Returns
4121 C ungrad.
4122       implicit none
4123       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4124       double precision vec(3)
4125       double precision scalar
4126       integer i,j
4127 c      write (2,*) 'ugrad',ugrad
4128 c      write (2,*) 'u',u
4129       do i=1,3
4130         vec(i)=scalar(ugrad(1,i),u(1))
4131       enddo
4132 c      write (2,*) 'vec',vec
4133       do i=1,3
4134         do j=1,3
4135           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4136         enddo
4137       enddo
4138 c      write (2,*) 'ungrad',ungrad
4139       return
4140       end
4141 C-----------------------------------------------------------------------------
4142       subroutine escp_soft_sphere(evdw2,evdw2_14)
4143 C
4144 C This subroutine calculates the excluded-volume interaction energy between
4145 C peptide-group centers and side chains and its gradient in virtual-bond and
4146 C side-chain vectors.
4147 C
4148       implicit real*8 (a-h,o-z)
4149       include 'DIMENSIONS'
4150       include 'COMMON.GEO'
4151       include 'COMMON.VAR'
4152       include 'COMMON.LOCAL'
4153       include 'COMMON.CHAIN'
4154       include 'COMMON.DERIV'
4155       include 'COMMON.INTERACT'
4156       include 'COMMON.FFIELD'
4157       include 'COMMON.IOUNITS'
4158       include 'COMMON.CONTROL'
4159       dimension ggg(3)
4160       evdw2=0.0D0
4161       evdw2_14=0.0d0
4162       r0_scp=4.5d0
4163 cd    print '(a)','Enter ESCP'
4164 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4165       do i=iatscp_s,iatscp_e
4166         iteli=itel(i)
4167         xi=0.5D0*(c(1,i)+c(1,i+1))
4168         yi=0.5D0*(c(2,i)+c(2,i+1))
4169         zi=0.5D0*(c(3,i)+c(3,i+1))
4170
4171         do iint=1,nscp_gr(i)
4172
4173         do j=iscpstart(i,iint),iscpend(i,iint)
4174           itypj=itype(j)
4175 C Uncomment following three lines for SC-p interactions
4176 c         xj=c(1,nres+j)-xi
4177 c         yj=c(2,nres+j)-yi
4178 c         zj=c(3,nres+j)-zi
4179 C Uncomment following three lines for Ca-p interactions
4180           xj=c(1,j)-xi
4181           yj=c(2,j)-yi
4182           zj=c(3,j)-zi
4183           rij=xj*xj+yj*yj+zj*zj
4184           r0ij=r0_scp
4185           r0ijsq=r0ij*r0ij
4186           if (rij.lt.r0ijsq) then
4187             evdwij=0.25d0*(rij-r0ijsq)**2
4188             fac=rij-r0ijsq
4189           else
4190             evdwij=0.0d0
4191             fac=0.0d0
4192           endif
4193           evdw2=evdw2+evdwij
4194 C
4195 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4196 C
4197           ggg(1)=xj*fac
4198           ggg(2)=yj*fac
4199           ggg(3)=zj*fac
4200 cgrad          if (j.lt.i) then
4201 cd          write (iout,*) 'j<i'
4202 C Uncomment following three lines for SC-p interactions
4203 c           do k=1,3
4204 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4205 c           enddo
4206 cgrad          else
4207 cd          write (iout,*) 'j>i'
4208 cgrad            do k=1,3
4209 cgrad              ggg(k)=-ggg(k)
4210 C Uncomment following line for SC-p interactions
4211 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4212 cgrad            enddo
4213 cgrad          endif
4214 cgrad          do k=1,3
4215 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4216 cgrad          enddo
4217 cgrad          kstart=min0(i+1,j)
4218 cgrad          kend=max0(i-1,j-1)
4219 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4220 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4221 cgrad          do k=kstart,kend
4222 cgrad            do l=1,3
4223 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4224 cgrad            enddo
4225 cgrad          enddo
4226           do k=1,3
4227             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4228             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4229           enddo
4230         enddo
4231
4232         enddo ! iint
4233       enddo ! i
4234       return
4235       end
4236 C-----------------------------------------------------------------------------
4237       subroutine escp(evdw2,evdw2_14)
4238 C
4239 C This subroutine calculates the excluded-volume interaction energy between
4240 C peptide-group centers and side chains and its gradient in virtual-bond and
4241 C side-chain vectors.
4242 C
4243       implicit real*8 (a-h,o-z)
4244       include 'DIMENSIONS'
4245       include 'COMMON.GEO'
4246       include 'COMMON.VAR'
4247       include 'COMMON.LOCAL'
4248       include 'COMMON.CHAIN'
4249       include 'COMMON.DERIV'
4250       include 'COMMON.INTERACT'
4251       include 'COMMON.FFIELD'
4252       include 'COMMON.IOUNITS'
4253       include 'COMMON.CONTROL'
4254       dimension ggg(3)
4255       evdw2=0.0D0
4256       evdw2_14=0.0d0
4257 cd    print '(a)','Enter ESCP'
4258 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4259       do i=iatscp_s,iatscp_e
4260         iteli=itel(i)
4261         xi=0.5D0*(c(1,i)+c(1,i+1))
4262         yi=0.5D0*(c(2,i)+c(2,i+1))
4263         zi=0.5D0*(c(3,i)+c(3,i+1))
4264
4265         do iint=1,nscp_gr(i)
4266
4267         do j=iscpstart(i,iint),iscpend(i,iint)
4268           itypj=itype(j)
4269 C Uncomment following three lines for SC-p interactions
4270 c         xj=c(1,nres+j)-xi
4271 c         yj=c(2,nres+j)-yi
4272 c         zj=c(3,nres+j)-zi
4273 C Uncomment following three lines for Ca-p interactions
4274           xj=c(1,j)-xi
4275           yj=c(2,j)-yi
4276           zj=c(3,j)-zi
4277           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4278           fac=rrij**expon2
4279           e1=fac*fac*aad(itypj,iteli)
4280           e2=fac*bad(itypj,iteli)
4281           if (iabs(j-i) .le. 2) then
4282             e1=scal14*e1
4283             e2=scal14*e2
4284             evdw2_14=evdw2_14+e1+e2
4285           endif
4286           evdwij=e1+e2
4287           evdw2=evdw2+evdwij
4288           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4289      &        'evdw2',i,j,evdwij
4290 C
4291 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4292 C
4293           fac=-(evdwij+e1)*rrij
4294           ggg(1)=xj*fac
4295           ggg(2)=yj*fac
4296           ggg(3)=zj*fac
4297 cgrad          if (j.lt.i) then
4298 cd          write (iout,*) 'j<i'
4299 C Uncomment following three lines for SC-p interactions
4300 c           do k=1,3
4301 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4302 c           enddo
4303 cgrad          else
4304 cd          write (iout,*) 'j>i'
4305 cgrad            do k=1,3
4306 cgrad              ggg(k)=-ggg(k)
4307 C Uncomment following line for SC-p interactions
4308 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4309 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4310 cgrad            enddo
4311 cgrad          endif
4312 cgrad          do k=1,3
4313 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4314 cgrad          enddo
4315 cgrad          kstart=min0(i+1,j)
4316 cgrad          kend=max0(i-1,j-1)
4317 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4318 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4319 cgrad          do k=kstart,kend
4320 cgrad            do l=1,3
4321 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4322 cgrad            enddo
4323 cgrad          enddo
4324           do k=1,3
4325             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4326             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4327           enddo
4328         enddo
4329
4330         enddo ! iint
4331       enddo ! i
4332       do i=1,nct
4333         do j=1,3
4334           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4335           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4336           gradx_scp(j,i)=expon*gradx_scp(j,i)
4337         enddo
4338       enddo
4339 C******************************************************************************
4340 C
4341 C                              N O T E !!!
4342 C
4343 C To save time the factor EXPON has been extracted from ALL components
4344 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4345 C use!
4346 C
4347 C******************************************************************************
4348       return
4349       end
4350 C--------------------------------------------------------------------------
4351       subroutine edis(ehpb)
4352 C
4353 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4354 C
4355       implicit real*8 (a-h,o-z)
4356       include 'DIMENSIONS'
4357       include 'COMMON.SBRIDGE'
4358       include 'COMMON.CHAIN'
4359       include 'COMMON.DERIV'
4360       include 'COMMON.VAR'
4361       include 'COMMON.INTERACT'
4362       include 'COMMON.IOUNITS'
4363       dimension ggg(3)
4364       ehpb=0.0D0
4365 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4366 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4367       if (link_end.eq.0) return
4368       do i=link_start,link_end
4369 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4370 C CA-CA distance used in regularization of structure.
4371         ii=ihpb(i)
4372         jj=jhpb(i)
4373 C iii and jjj point to the residues for which the distance is assigned.
4374         if (ii.gt.nres) then
4375           iii=ii-nres
4376           jjj=jj-nres
4377         else
4378           iii=ii
4379           jjj=jj
4380         endif
4381 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4382 c     &    dhpb(i),dhpb1(i),forcon(i)
4383 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4384 C    distance and angle dependent SS bond potential.
4385 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4386 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4387         if (.not.dyn_ss .and. i.le.nss) then
4388 C 15/02/13 CC dynamic SSbond - additional check
4389          if (ii.gt.nres
4390      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4391           call ssbond_ene(iii,jjj,eij)
4392           ehpb=ehpb+2*eij
4393          endif
4394 cd          write (iout,*) "eij",eij
4395         else if (ii.gt.nres .and. jj.gt.nres) then
4396 c Restraints from contact prediction
4397           dd=dist(ii,jj)
4398           if (dhpb1(i).gt.0.0d0) then
4399             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4400             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4401 c            write (iout,*) "beta nmr",
4402 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4403           else
4404             dd=dist(ii,jj)
4405             rdis=dd-dhpb(i)
4406 C Get the force constant corresponding to this distance.
4407             waga=forcon(i)
4408 C Calculate the contribution to energy.
4409             ehpb=ehpb+waga*rdis*rdis
4410 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4411 C
4412 C Evaluate gradient.
4413 C
4414             fac=waga*rdis/dd
4415           endif
4416           do j=1,3
4417             ggg(j)=fac*(c(j,jj)-c(j,ii))
4418           enddo
4419           do j=1,3
4420             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4421             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4422           enddo
4423           do k=1,3
4424             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4425             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4426           enddo
4427         else
4428 C Calculate the distance between the two points and its difference from the
4429 C target distance.
4430           dd=dist(ii,jj)
4431           if (dhpb1(i).gt.0.0d0) then
4432             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4433             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4434 c            write (iout,*) "alph nmr",
4435 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4436           else
4437             rdis=dd-dhpb(i)
4438 C Get the force constant corresponding to this distance.
4439             waga=forcon(i)
4440 C Calculate the contribution to energy.
4441             ehpb=ehpb+waga*rdis*rdis
4442 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4443 C
4444 C Evaluate gradient.
4445 C
4446             fac=waga*rdis/dd
4447           endif
4448 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4449 cd   &   ' waga=',waga,' fac=',fac
4450             do j=1,3
4451               ggg(j)=fac*(c(j,jj)-c(j,ii))
4452             enddo
4453 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4454 C If this is a SC-SC distance, we need to calculate the contributions to the
4455 C Cartesian gradient in the SC vectors (ghpbx).
4456           if (iii.lt.ii) then
4457           do j=1,3
4458             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4459             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4460           enddo
4461           endif
4462 cgrad        do j=iii,jjj-1
4463 cgrad          do k=1,3
4464 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4465 cgrad          enddo
4466 cgrad        enddo
4467           do k=1,3
4468             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4469             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4470           enddo
4471         endif
4472       enddo
4473       ehpb=0.5D0*ehpb
4474       return
4475       end
4476 C--------------------------------------------------------------------------
4477       subroutine ssbond_ene(i,j,eij)
4478 C
4479 C Calculate the distance and angle dependent SS-bond potential energy
4480 C using a free-energy function derived based on RHF/6-31G** ab initio
4481 C calculations of diethyl disulfide.
4482 C
4483 C A. Liwo and U. Kozlowska, 11/24/03
4484 C
4485       implicit real*8 (a-h,o-z)
4486       include 'DIMENSIONS'
4487       include 'COMMON.SBRIDGE'
4488       include 'COMMON.CHAIN'
4489       include 'COMMON.DERIV'
4490       include 'COMMON.LOCAL'
4491       include 'COMMON.INTERACT'
4492       include 'COMMON.VAR'
4493       include 'COMMON.IOUNITS'
4494       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4495       itypi=itype(i)
4496       xi=c(1,nres+i)
4497       yi=c(2,nres+i)
4498       zi=c(3,nres+i)
4499       dxi=dc_norm(1,nres+i)
4500       dyi=dc_norm(2,nres+i)
4501       dzi=dc_norm(3,nres+i)
4502 c      dsci_inv=dsc_inv(itypi)
4503       dsci_inv=vbld_inv(nres+i)
4504       itypj=itype(j)
4505 c      dscj_inv=dsc_inv(itypj)
4506       dscj_inv=vbld_inv(nres+j)
4507       xj=c(1,nres+j)-xi
4508       yj=c(2,nres+j)-yi
4509       zj=c(3,nres+j)-zi
4510       dxj=dc_norm(1,nres+j)
4511       dyj=dc_norm(2,nres+j)
4512       dzj=dc_norm(3,nres+j)
4513       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4514       rij=dsqrt(rrij)
4515       erij(1)=xj*rij
4516       erij(2)=yj*rij
4517       erij(3)=zj*rij
4518       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4519       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4520       om12=dxi*dxj+dyi*dyj+dzi*dzj
4521       do k=1,3
4522         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4523         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4524       enddo
4525       rij=1.0d0/rij
4526       deltad=rij-d0cm
4527       deltat1=1.0d0-om1
4528       deltat2=1.0d0+om2
4529       deltat12=om2-om1+2.0d0
4530       cosphi=om12-om1*om2
4531       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4532      &  +akct*deltad*deltat12+ebr
4533      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4534 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4535 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4536 c     &  " deltat12",deltat12," eij",eij
4537       ed=2*akcm*deltad+akct*deltat12
4538       pom1=akct*deltad
4539       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4540       eom1=-2*akth*deltat1-pom1-om2*pom2
4541       eom2= 2*akth*deltat2+pom1-om1*pom2
4542       eom12=pom2
4543       do k=1,3
4544         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4545         ghpbx(k,i)=ghpbx(k,i)-ggk
4546      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4547      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4548         ghpbx(k,j)=ghpbx(k,j)+ggk
4549      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4550      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4551         ghpbc(k,i)=ghpbc(k,i)-ggk
4552         ghpbc(k,j)=ghpbc(k,j)+ggk
4553       enddo
4554 C
4555 C Calculate the components of the gradient in DC and X
4556 C
4557 cgrad      do k=i,j-1
4558 cgrad        do l=1,3
4559 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4560 cgrad        enddo
4561 cgrad      enddo
4562       return
4563       end
4564 C--------------------------------------------------------------------------
4565       subroutine ebond(estr)
4566 c
4567 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4568 c
4569       implicit real*8 (a-h,o-z)
4570       include 'DIMENSIONS'
4571       include 'COMMON.LOCAL'
4572       include 'COMMON.GEO'
4573       include 'COMMON.INTERACT'
4574       include 'COMMON.DERIV'
4575       include 'COMMON.VAR'
4576       include 'COMMON.CHAIN'
4577       include 'COMMON.IOUNITS'
4578       include 'COMMON.NAMES'
4579       include 'COMMON.FFIELD'
4580       include 'COMMON.CONTROL'
4581       include 'COMMON.SETUP'
4582       double precision u(3),ud(3)
4583       estr=0.0d0
4584       do i=ibondp_start,ibondp_end
4585         diff = vbld(i)-vbldp0
4586 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4587         estr=estr+diff*diff
4588         do j=1,3
4589           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4590         enddo
4591 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4592       enddo
4593       estr=0.5d0*AKP*estr
4594 c
4595 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4596 c
4597       do i=ibond_start,ibond_end
4598         iti=itype(i)
4599         if (iti.ne.10) then
4600           nbi=nbondterm(iti)
4601           if (nbi.eq.1) then
4602             diff=vbld(i+nres)-vbldsc0(1,iti)
4603 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4604 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4605             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4606             do j=1,3
4607               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4608             enddo
4609           else
4610             do j=1,nbi
4611               diff=vbld(i+nres)-vbldsc0(j,iti)
4612               ud(j)=aksc(j,iti)*diff
4613               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4614             enddo
4615             uprod=u(1)
4616             do j=2,nbi
4617               uprod=uprod*u(j)
4618             enddo
4619             usum=0.0d0
4620             usumsqder=0.0d0
4621             do j=1,nbi
4622               uprod1=1.0d0
4623               uprod2=1.0d0
4624               do k=1,nbi
4625                 if (k.ne.j) then
4626                   uprod1=uprod1*u(k)
4627                   uprod2=uprod2*u(k)*u(k)
4628                 endif
4629               enddo
4630               usum=usum+uprod1
4631               usumsqder=usumsqder+ud(j)*uprod2
4632             enddo
4633             estr=estr+uprod/usum
4634             do j=1,3
4635              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4636             enddo
4637           endif
4638         endif
4639       enddo
4640       return
4641       end
4642 #ifdef CRYST_THETA
4643 C--------------------------------------------------------------------------
4644       subroutine ebend(etheta)
4645 C
4646 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4647 C angles gamma and its derivatives in consecutive thetas and gammas.
4648 C
4649       implicit real*8 (a-h,o-z)
4650       include 'DIMENSIONS'
4651       include 'COMMON.LOCAL'
4652       include 'COMMON.GEO'
4653       include 'COMMON.INTERACT'
4654       include 'COMMON.DERIV'
4655       include 'COMMON.VAR'
4656       include 'COMMON.CHAIN'
4657       include 'COMMON.IOUNITS'
4658       include 'COMMON.NAMES'
4659       include 'COMMON.FFIELD'
4660       include 'COMMON.CONTROL'
4661       common /calcthet/ term1,term2,termm,diffak,ratak,
4662      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4663      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4664       double precision y(2),z(2)
4665       delta=0.02d0*pi
4666 c      time11=dexp(-2*time)
4667 c      time12=1.0d0
4668       etheta=0.0D0
4669 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4670       do i=ithet_start,ithet_end
4671 C Zero the energy function and its derivative at 0 or pi.
4672         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4673         it=itype(i-1)
4674         if (i.gt.3) then
4675 #ifdef OSF
4676           phii=phi(i)
4677           if (phii.ne.phii) phii=150.0
4678 #else
4679           phii=phi(i)
4680 #endif
4681           y(1)=dcos(phii)
4682           y(2)=dsin(phii)
4683         else
4684           y(1)=0.0D0
4685           y(2)=0.0D0
4686         endif
4687         if (i.lt.nres) then
4688 #ifdef OSF
4689           phii1=phi(i+1)
4690           if (phii1.ne.phii1) phii1=150.0
4691           phii1=pinorm(phii1)
4692           z(1)=cos(phii1)
4693 #else
4694           phii1=phi(i+1)
4695           z(1)=dcos(phii1)
4696 #endif
4697           z(2)=dsin(phii1)
4698         else
4699           z(1)=0.0D0
4700           z(2)=0.0D0
4701         endif
4702 C Calculate the "mean" value of theta from the part of the distribution
4703 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4704 C In following comments this theta will be referred to as t_c.
4705         thet_pred_mean=0.0d0
4706         do k=1,2
4707           athetk=athet(k,it)
4708           bthetk=bthet(k,it)
4709           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4710         enddo
4711         dthett=thet_pred_mean*ssd
4712         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4713 C Derivatives of the "mean" values in gamma1 and gamma2.
4714         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4715         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4716         if (theta(i).gt.pi-delta) then
4717           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4718      &         E_tc0)
4719           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4720           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4721           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4722      &        E_theta)
4723           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4724      &        E_tc)
4725         else if (theta(i).lt.delta) then
4726           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4727           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4728           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4729      &        E_theta)
4730           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4731           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4732      &        E_tc)
4733         else
4734           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4735      &        E_theta,E_tc)
4736         endif
4737         etheta=etheta+ethetai
4738         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4739      &      'ebend',i,ethetai
4740         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4741         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4742         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4743       enddo
4744 C Ufff.... We've done all this!!!
4745       return
4746       end
4747 C---------------------------------------------------------------------------
4748       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4749      &     E_tc)
4750       implicit real*8 (a-h,o-z)
4751       include 'DIMENSIONS'
4752       include 'COMMON.LOCAL'
4753       include 'COMMON.IOUNITS'
4754       common /calcthet/ term1,term2,termm,diffak,ratak,
4755      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4756      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4757 C Calculate the contributions to both Gaussian lobes.
4758 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4759 C The "polynomial part" of the "standard deviation" of this part of
4760 C the distribution.
4761         sig=polthet(3,it)
4762         do j=2,0,-1
4763           sig=sig*thet_pred_mean+polthet(j,it)
4764         enddo
4765 C Derivative of the "interior part" of the "standard deviation of the"
4766 C gamma-dependent Gaussian lobe in t_c.
4767         sigtc=3*polthet(3,it)
4768         do j=2,1,-1
4769           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4770         enddo
4771         sigtc=sig*sigtc
4772 C Set the parameters of both Gaussian lobes of the distribution.
4773 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4774         fac=sig*sig+sigc0(it)
4775         sigcsq=fac+fac
4776         sigc=1.0D0/sigcsq
4777 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4778         sigsqtc=-4.0D0*sigcsq*sigtc
4779 c       print *,i,sig,sigtc,sigsqtc
4780 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4781         sigtc=-sigtc/(fac*fac)
4782 C Following variable is sigma(t_c)**(-2)
4783         sigcsq=sigcsq*sigcsq
4784         sig0i=sig0(it)
4785         sig0inv=1.0D0/sig0i**2
4786         delthec=thetai-thet_pred_mean
4787         delthe0=thetai-theta0i
4788         term1=-0.5D0*sigcsq*delthec*delthec
4789         term2=-0.5D0*sig0inv*delthe0*delthe0
4790 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4791 C NaNs in taking the logarithm. We extract the largest exponent which is added
4792 C to the energy (this being the log of the distribution) at the end of energy
4793 C term evaluation for this virtual-bond angle.
4794         if (term1.gt.term2) then
4795           termm=term1
4796           term2=dexp(term2-termm)
4797           term1=1.0d0
4798         else
4799           termm=term2
4800           term1=dexp(term1-termm)
4801           term2=1.0d0
4802         endif
4803 C The ratio between the gamma-independent and gamma-dependent lobes of
4804 C the distribution is a Gaussian function of thet_pred_mean too.
4805         diffak=gthet(2,it)-thet_pred_mean
4806         ratak=diffak/gthet(3,it)**2
4807         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4808 C Let's differentiate it in thet_pred_mean NOW.
4809         aktc=ak*ratak
4810 C Now put together the distribution terms to make complete distribution.
4811         termexp=term1+ak*term2
4812         termpre=sigc+ak*sig0i
4813 C Contribution of the bending energy from this theta is just the -log of
4814 C the sum of the contributions from the two lobes and the pre-exponential
4815 C factor. Simple enough, isn't it?
4816         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4817 C NOW the derivatives!!!
4818 C 6/6/97 Take into account the deformation.
4819         E_theta=(delthec*sigcsq*term1
4820      &       +ak*delthe0*sig0inv*term2)/termexp
4821         E_tc=((sigtc+aktc*sig0i)/termpre
4822      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4823      &       aktc*term2)/termexp)
4824       return
4825       end
4826 c-----------------------------------------------------------------------------
4827       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4828       implicit real*8 (a-h,o-z)
4829       include 'DIMENSIONS'
4830       include 'COMMON.LOCAL'
4831       include 'COMMON.IOUNITS'
4832       common /calcthet/ term1,term2,termm,diffak,ratak,
4833      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4834      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4835       delthec=thetai-thet_pred_mean
4836       delthe0=thetai-theta0i
4837 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4838       t3 = thetai-thet_pred_mean
4839       t6 = t3**2
4840       t9 = term1
4841       t12 = t3*sigcsq
4842       t14 = t12+t6*sigsqtc
4843       t16 = 1.0d0
4844       t21 = thetai-theta0i
4845       t23 = t21**2
4846       t26 = term2
4847       t27 = t21*t26
4848       t32 = termexp
4849       t40 = t32**2
4850       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4851      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4852      & *(-t12*t9-ak*sig0inv*t27)
4853       return
4854       end
4855 #else
4856 C--------------------------------------------------------------------------
4857       subroutine ebend(etheta)
4858 C
4859 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4860 C angles gamma and its derivatives in consecutive thetas and gammas.
4861 C ab initio-derived potentials from
4862 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4863 C
4864       implicit real*8 (a-h,o-z)
4865       include 'DIMENSIONS'
4866       include 'COMMON.LOCAL'
4867       include 'COMMON.GEO'
4868       include 'COMMON.INTERACT'
4869       include 'COMMON.DERIV'
4870       include 'COMMON.VAR'
4871       include 'COMMON.CHAIN'
4872       include 'COMMON.IOUNITS'
4873       include 'COMMON.NAMES'
4874       include 'COMMON.FFIELD'
4875       include 'COMMON.CONTROL'
4876       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4877      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4878      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4879      & sinph1ph2(maxdouble,maxdouble)
4880       logical lprn /.false./, lprn1 /.false./
4881       etheta=0.0D0
4882 c      write (iout,*) "EBEND ithet_start",ithet_start,
4883 c     &     " ithet_end",ithet_end
4884       do i=ithet_start,ithet_end
4885         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4886      &(itype(i).eq.ntyp1)) cycle
4887         dethetai=0.0d0
4888         dephii=0.0d0
4889         dephii1=0.0d0
4890         theti2=0.5d0*theta(i)
4891         ityp2=ithetyp(itype(i-1))
4892         do k=1,nntheterm
4893           coskt(k)=dcos(k*theti2)
4894           sinkt(k)=dsin(k*theti2)
4895         enddo
4896 C        if (i.gt.3) then
4897          if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4898 #ifdef OSF
4899           phii=phi(i)
4900           if (phii.ne.phii) phii=150.0
4901 #else
4902           phii=phi(i)
4903 #endif
4904           ityp1=ithetyp(itype(i-2))
4905           do k=1,nsingle
4906             cosph1(k)=dcos(k*phii)
4907             sinph1(k)=dsin(k*phii)
4908           enddo
4909         else
4910           phii=0.0d0
4911           ityp1=ithetyp(itype(i-2))
4912           do k=1,nsingle
4913             cosph1(k)=0.0d0
4914             sinph1(k)=0.0d0
4915           enddo
4916         endif
4917         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4918 #ifdef OSF
4919           phii1=phi(i+1)
4920           if (phii1.ne.phii1) phii1=150.0
4921           phii1=pinorm(phii1)
4922 #else
4923           phii1=phi(i+1)
4924 #endif
4925           ityp3=ithetyp(itype(i))
4926           do k=1,nsingle
4927             cosph2(k)=dcos(k*phii1)
4928             sinph2(k)=dsin(k*phii1)
4929           enddo
4930         else
4931           phii1=0.0d0
4932           ityp3=ithetyp(itype(i))
4933           do k=1,nsingle
4934             cosph2(k)=0.0d0
4935             sinph2(k)=0.0d0
4936           enddo
4937         endif
4938         ethetai=aa0thet(ityp1,ityp2,ityp3)
4939         do k=1,ndouble
4940           do l=1,k-1
4941             ccl=cosph1(l)*cosph2(k-l)
4942             ssl=sinph1(l)*sinph2(k-l)
4943             scl=sinph1(l)*cosph2(k-l)
4944             csl=cosph1(l)*sinph2(k-l)
4945             cosph1ph2(l,k)=ccl-ssl
4946             cosph1ph2(k,l)=ccl+ssl
4947             sinph1ph2(l,k)=scl+csl
4948             sinph1ph2(k,l)=scl-csl
4949           enddo
4950         enddo
4951         if (lprn) then
4952         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4953      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4954         write (iout,*) "coskt and sinkt"
4955         do k=1,nntheterm
4956           write (iout,*) k,coskt(k),sinkt(k)
4957         enddo
4958         endif
4959         do k=1,ntheterm
4960           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4961           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4962      &      *coskt(k)
4963           if (lprn)
4964      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4965      &     " ethetai",ethetai
4966         enddo
4967         if (lprn) then
4968         write (iout,*) "cosph and sinph"
4969         do k=1,nsingle
4970           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4971         enddo
4972         write (iout,*) "cosph1ph2 and sinph2ph2"
4973         do k=2,ndouble
4974           do l=1,k-1
4975             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4976      &         sinph1ph2(l,k),sinph1ph2(k,l)
4977           enddo
4978         enddo
4979         write(iout,*) "ethetai",ethetai
4980         endif
4981         do m=1,ntheterm2
4982           do k=1,nsingle
4983             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4984      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4985      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4986      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4987             ethetai=ethetai+sinkt(m)*aux
4988             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4989             dephii=dephii+k*sinkt(m)*(
4990      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4991      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4992             dephii1=dephii1+k*sinkt(m)*(
4993      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4994      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4995             if (lprn)
4996      &      write (iout,*) "m",m," k",k," bbthet",
4997      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4998      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4999      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5000      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5001           enddo
5002         enddo
5003         if (lprn)
5004      &  write(iout,*) "ethetai",ethetai
5005         do m=1,ntheterm3
5006           do k=2,ndouble
5007             do l=1,k-1
5008               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5009      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5010      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5011      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5012               ethetai=ethetai+sinkt(m)*aux
5013               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5014               dephii=dephii+l*sinkt(m)*(
5015      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5016      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5017      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5018      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5019               dephii1=dephii1+(k-l)*sinkt(m)*(
5020      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5021      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5022      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5023      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5024               if (lprn) then
5025               write (iout,*) "m",m," k",k," l",l," ffthet",
5026      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5027      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5028      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5029      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5030               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5031      &            cosph1ph2(k,l)*sinkt(m),
5032      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5033               endif
5034             enddo
5035           enddo
5036         enddo
5037 10      continue
5038 c        lprn1=.true.
5039         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
5040      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
5041      &   phii1*rad2deg,ethetai
5042 c        lprn1=.false.
5043         etheta=etheta+ethetai
5044         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5045         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5046         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5047       enddo
5048       return
5049       end
5050 #endif
5051 #ifdef CRYST_SC
5052 c-----------------------------------------------------------------------------
5053       subroutine esc(escloc)
5054 C Calculate the local energy of a side chain and its derivatives in the
5055 C corresponding virtual-bond valence angles THETA and the spherical angles
5056 C ALPHA and OMEGA.
5057       implicit real*8 (a-h,o-z)
5058       include 'DIMENSIONS'
5059       include 'COMMON.GEO'
5060       include 'COMMON.LOCAL'
5061       include 'COMMON.VAR'
5062       include 'COMMON.INTERACT'
5063       include 'COMMON.DERIV'
5064       include 'COMMON.CHAIN'
5065       include 'COMMON.IOUNITS'
5066       include 'COMMON.NAMES'
5067       include 'COMMON.FFIELD'
5068       include 'COMMON.CONTROL'
5069       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5070      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5071       common /sccalc/ time11,time12,time112,theti,it,nlobit
5072       delta=0.02d0*pi
5073       escloc=0.0D0
5074 c     write (iout,'(a)') 'ESC'
5075       do i=loc_start,loc_end
5076         it=itype(i)
5077         if (it.eq.10) goto 1
5078         nlobit=nlob(it)
5079 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5080 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5081         theti=theta(i+1)-pipol
5082         x(1)=dtan(theti)
5083         x(2)=alph(i)
5084         x(3)=omeg(i)
5085
5086         if (x(2).gt.pi-delta) then
5087           xtemp(1)=x(1)
5088           xtemp(2)=pi-delta
5089           xtemp(3)=x(3)
5090           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5091           xtemp(2)=pi
5092           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5093           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5094      &        escloci,dersc(2))
5095           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5096      &        ddersc0(1),dersc(1))
5097           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5098      &        ddersc0(3),dersc(3))
5099           xtemp(2)=pi-delta
5100           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5101           xtemp(2)=pi
5102           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5103           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5104      &            dersc0(2),esclocbi,dersc02)
5105           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5106      &            dersc12,dersc01)
5107           call splinthet(x(2),0.5d0*delta,ss,ssd)
5108           dersc0(1)=dersc01
5109           dersc0(2)=dersc02
5110           dersc0(3)=0.0d0
5111           do k=1,3
5112             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5113           enddo
5114           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5115 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5116 c    &             esclocbi,ss,ssd
5117           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5118 c         escloci=esclocbi
5119 c         write (iout,*) escloci
5120         else if (x(2).lt.delta) then
5121           xtemp(1)=x(1)
5122           xtemp(2)=delta
5123           xtemp(3)=x(3)
5124           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5125           xtemp(2)=0.0d0
5126           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5127           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5128      &        escloci,dersc(2))
5129           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5130      &        ddersc0(1),dersc(1))
5131           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5132      &        ddersc0(3),dersc(3))
5133           xtemp(2)=delta
5134           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5135           xtemp(2)=0.0d0
5136           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5137           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5138      &            dersc0(2),esclocbi,dersc02)
5139           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5140      &            dersc12,dersc01)
5141           dersc0(1)=dersc01
5142           dersc0(2)=dersc02
5143           dersc0(3)=0.0d0
5144           call splinthet(x(2),0.5d0*delta,ss,ssd)
5145           do k=1,3
5146             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5147           enddo
5148           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5149 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5150 c    &             esclocbi,ss,ssd
5151           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5152 c         write (iout,*) escloci
5153         else
5154           call enesc(x,escloci,dersc,ddummy,.false.)
5155         endif
5156
5157         escloc=escloc+escloci
5158         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5159      &     'escloc',i,escloci
5160 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5161
5162         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5163      &   wscloc*dersc(1)
5164         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5165         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5166     1   continue
5167       enddo
5168       return
5169       end
5170 C---------------------------------------------------------------------------
5171       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5172       implicit real*8 (a-h,o-z)
5173       include 'DIMENSIONS'
5174       include 'COMMON.GEO'
5175       include 'COMMON.LOCAL'
5176       include 'COMMON.IOUNITS'
5177       common /sccalc/ time11,time12,time112,theti,it,nlobit
5178       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5179       double precision contr(maxlob,-1:1)
5180       logical mixed
5181 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5182         escloc_i=0.0D0
5183         do j=1,3
5184           dersc(j)=0.0D0
5185           if (mixed) ddersc(j)=0.0d0
5186         enddo
5187         x3=x(3)
5188
5189 C Because of periodicity of the dependence of the SC energy in omega we have
5190 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5191 C To avoid underflows, first compute & store the exponents.
5192
5193         do iii=-1,1
5194
5195           x(3)=x3+iii*dwapi
5196
5197           do j=1,nlobit
5198             do k=1,3
5199               z(k)=x(k)-censc(k,j,it)
5200             enddo
5201             do k=1,3
5202               Axk=0.0D0
5203               do l=1,3
5204                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5205               enddo
5206               Ax(k,j,iii)=Axk
5207             enddo
5208             expfac=0.0D0
5209             do k=1,3
5210               expfac=expfac+Ax(k,j,iii)*z(k)
5211             enddo
5212             contr(j,iii)=expfac
5213           enddo ! j
5214
5215         enddo ! iii
5216
5217         x(3)=x3
5218 C As in the case of ebend, we want to avoid underflows in exponentiation and
5219 C subsequent NaNs and INFs in energy calculation.
5220 C Find the largest exponent
5221         emin=contr(1,-1)
5222         do iii=-1,1
5223           do j=1,nlobit
5224             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5225           enddo
5226         enddo
5227         emin=0.5D0*emin
5228 cd      print *,'it=',it,' emin=',emin
5229
5230 C Compute the contribution to SC energy and derivatives
5231         do iii=-1,1
5232
5233           do j=1,nlobit
5234 #ifdef OSF
5235             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5236             if(adexp.ne.adexp) adexp=1.0
5237             expfac=dexp(adexp)
5238 #else
5239             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5240 #endif
5241 cd          print *,'j=',j,' expfac=',expfac
5242             escloc_i=escloc_i+expfac
5243             do k=1,3
5244               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5245             enddo
5246             if (mixed) then
5247               do k=1,3,2
5248                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5249      &            +gaussc(k,2,j,it))*expfac
5250               enddo
5251             endif
5252           enddo
5253
5254         enddo ! iii
5255
5256         dersc(1)=dersc(1)/cos(theti)**2
5257         ddersc(1)=ddersc(1)/cos(theti)**2
5258         ddersc(3)=ddersc(3)
5259
5260         escloci=-(dlog(escloc_i)-emin)
5261         do j=1,3
5262           dersc(j)=dersc(j)/escloc_i
5263         enddo
5264         if (mixed) then
5265           do j=1,3,2
5266             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5267           enddo
5268         endif
5269       return
5270       end
5271 C------------------------------------------------------------------------------
5272       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5273       implicit real*8 (a-h,o-z)
5274       include 'DIMENSIONS'
5275       include 'COMMON.GEO'
5276       include 'COMMON.LOCAL'
5277       include 'COMMON.IOUNITS'
5278       common /sccalc/ time11,time12,time112,theti,it,nlobit
5279       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5280       double precision contr(maxlob)
5281       logical mixed
5282
5283       escloc_i=0.0D0
5284
5285       do j=1,3
5286         dersc(j)=0.0D0
5287       enddo
5288
5289       do j=1,nlobit
5290         do k=1,2
5291           z(k)=x(k)-censc(k,j,it)
5292         enddo
5293         z(3)=dwapi
5294         do k=1,3
5295           Axk=0.0D0
5296           do l=1,3
5297             Axk=Axk+gaussc(l,k,j,it)*z(l)
5298           enddo
5299           Ax(k,j)=Axk
5300         enddo
5301         expfac=0.0D0
5302         do k=1,3
5303           expfac=expfac+Ax(k,j)*z(k)
5304         enddo
5305         contr(j)=expfac
5306       enddo ! j
5307
5308 C As in the case of ebend, we want to avoid underflows in exponentiation and
5309 C subsequent NaNs and INFs in energy calculation.
5310 C Find the largest exponent
5311       emin=contr(1)
5312       do j=1,nlobit
5313         if (emin.gt.contr(j)) emin=contr(j)
5314       enddo
5315       emin=0.5D0*emin
5316
5317 C Compute the contribution to SC energy and derivatives
5318
5319       dersc12=0.0d0
5320       do j=1,nlobit
5321         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5322         escloc_i=escloc_i+expfac
5323         do k=1,2
5324           dersc(k)=dersc(k)+Ax(k,j)*expfac
5325         enddo
5326         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5327      &            +gaussc(1,2,j,it))*expfac
5328         dersc(3)=0.0d0
5329       enddo
5330
5331       dersc(1)=dersc(1)/cos(theti)**2
5332       dersc12=dersc12/cos(theti)**2
5333       escloci=-(dlog(escloc_i)-emin)
5334       do j=1,2
5335         dersc(j)=dersc(j)/escloc_i
5336       enddo
5337       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5338       return
5339       end
5340 #else
5341 c----------------------------------------------------------------------------------
5342       subroutine esc(escloc)
5343 C Calculate the local energy of a side chain and its derivatives in the
5344 C corresponding virtual-bond valence angles THETA and the spherical angles
5345 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5346 C added by Urszula Kozlowska. 07/11/2007
5347 C
5348       implicit real*8 (a-h,o-z)
5349       include 'DIMENSIONS'
5350       include 'COMMON.GEO'
5351       include 'COMMON.LOCAL'
5352       include 'COMMON.VAR'
5353       include 'COMMON.SCROT'
5354       include 'COMMON.INTERACT'
5355       include 'COMMON.DERIV'
5356       include 'COMMON.CHAIN'
5357       include 'COMMON.IOUNITS'
5358       include 'COMMON.NAMES'
5359       include 'COMMON.FFIELD'
5360       include 'COMMON.CONTROL'
5361       include 'COMMON.VECTORS'
5362       double precision x_prime(3),y_prime(3),z_prime(3)
5363      &    , sumene,dsc_i,dp2_i,x(65),
5364      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5365      &    de_dxx,de_dyy,de_dzz,de_dt
5366       double precision s1_t,s1_6_t,s2_t,s2_6_t
5367       double precision
5368      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5369      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5370      & dt_dCi(3),dt_dCi1(3)
5371       common /sccalc/ time11,time12,time112,theti,it,nlobit
5372       delta=0.02d0*pi
5373       escloc=0.0D0
5374 c      write(iout,*) "ESC: loc_start",loc_start," loc_end",loc_end
5375       do i=loc_start,loc_end
5376         costtab(i+1) =dcos(theta(i+1))
5377         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5378         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5379         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5380         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5381         cosfac=dsqrt(cosfac2)
5382         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5383         sinfac=dsqrt(sinfac2)
5384         it=itype(i)
5385         if (it.eq.10) goto 1
5386 c
5387 C  Compute the axes of tghe local cartesian coordinates system; store in
5388 c   x_prime, y_prime and z_prime
5389 c
5390         do j=1,3
5391           x_prime(j) = 0.00
5392           y_prime(j) = 0.00
5393           z_prime(j) = 0.00
5394         enddo
5395 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5396 C     &   dc_norm(3,i+nres)
5397         do j = 1,3
5398           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5399           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5400         enddo
5401         do j = 1,3
5402           z_prime(j) = -uz(j,i-1)
5403         enddo
5404 c       write (2,*) "i",i
5405 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5406 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5407 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5408 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5409 c      & " xy",scalar(x_prime(1),y_prime(1)),
5410 c      & " xz",scalar(x_prime(1),z_prime(1)),
5411 c      & " yy",scalar(y_prime(1),y_prime(1)),
5412 c      & " yz",scalar(y_prime(1),z_prime(1)),
5413 c      & " zz",scalar(z_prime(1),z_prime(1))
5414 c
5415 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5416 C to local coordinate system. Store in xx, yy, zz.
5417 c
5418         xx=0.0d0
5419         yy=0.0d0
5420         zz=0.0d0
5421         do j = 1,3
5422           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5423           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5424           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5425         enddo
5426
5427         xxtab(i)=xx
5428         yytab(i)=yy
5429         zztab(i)=zz
5430 C
5431 C Compute the energy of the ith side cbain
5432 C
5433 c        write (2,*) "xx",xx," yy",yy," zz",zz
5434         it=itype(i)
5435         do j = 1,65
5436           x(j) = sc_parmin(j,it)
5437         enddo
5438 #ifdef CHECK_COORD
5439 Cc diagnostics - remove later
5440         xx1 = dcos(alph(2))
5441         yy1 = dsin(alph(2))*dcos(omeg(2))
5442         zz1 = -dsin(alph(2))*dsin(omeg(2))
5443         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5444      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5445      &    xx1,yy1,zz1
5446 C,"  --- ", xx_w,yy_w,zz_w
5447 c end diagnostics
5448 #endif
5449         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5450      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5451      &   + x(10)*yy*zz
5452         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5453      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5454      & + x(20)*yy*zz
5455         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5456      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5457      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5458      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5459      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5460      &  +x(40)*xx*yy*zz
5461         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5462      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5463      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5464      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5465      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5466      &  +x(60)*xx*yy*zz
5467         dsc_i   = 0.743d0+x(61)
5468         dp2_i   = 1.9d0+x(62)
5469         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5470      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5471         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5472      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5473         s1=(1+x(63))/(0.1d0 + dscp1)
5474         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5475         s2=(1+x(65))/(0.1d0 + dscp2)
5476         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5477         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5478      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5479 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5480 c     &   sumene4,
5481 c     &   dscp1,dscp2,sumene
5482 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5483         escloc = escloc + sumene
5484 c        write (2,*) "i",i," escloc",sumene,escloc
5485 #ifdef DEBUG
5486 C
5487 C This section to check the numerical derivatives of the energy of ith side
5488 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5489 C #define DEBUG in the code to turn it on.
5490 C
5491         write (2,*) "sumene               =",sumene
5492         aincr=1.0d-7
5493         xxsave=xx
5494         xx=xx+aincr
5495         write (2,*) xx,yy,zz
5496         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5497         de_dxx_num=(sumenep-sumene)/aincr
5498         xx=xxsave
5499         write (2,*) "xx+ sumene from enesc=",sumenep
5500         yysave=yy
5501         yy=yy+aincr
5502         write (2,*) xx,yy,zz
5503         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5504         de_dyy_num=(sumenep-sumene)/aincr
5505         yy=yysave
5506         write (2,*) "yy+ sumene from enesc=",sumenep
5507         zzsave=zz
5508         zz=zz+aincr
5509         write (2,*) xx,yy,zz
5510         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5511         de_dzz_num=(sumenep-sumene)/aincr
5512         zz=zzsave
5513         write (2,*) "zz+ sumene from enesc=",sumenep
5514         costsave=cost2tab(i+1)
5515         sintsave=sint2tab(i+1)
5516         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5517         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5518         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5519         de_dt_num=(sumenep-sumene)/aincr
5520         write (2,*) " t+ sumene from enesc=",sumenep
5521         cost2tab(i+1)=costsave
5522         sint2tab(i+1)=sintsave
5523 C End of diagnostics section.
5524 #endif
5525 C
5526 C Compute the gradient of esc
5527 C
5528         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5529         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5530         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5531         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5532         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5533         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5534         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5535         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5536         pom1=(sumene3*sint2tab(i+1)+sumene1)
5537      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5538         pom2=(sumene4*cost2tab(i+1)+sumene2)
5539      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5540         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5541         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5542      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5543      &  +x(40)*yy*zz
5544         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5545         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5546      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5547      &  +x(60)*yy*zz
5548         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5549      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5550      &        +(pom1+pom2)*pom_dx
5551 #ifdef DEBUG
5552         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5553 #endif
5554 C
5555         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5556         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5557      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5558      &  +x(40)*xx*zz
5559         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5560         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5561      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5562      &  +x(59)*zz**2 +x(60)*xx*zz
5563         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5564      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5565      &        +(pom1-pom2)*pom_dy
5566 #ifdef DEBUG
5567         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5568 #endif
5569 C
5570         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5571      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5572      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5573      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5574      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5575      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5576      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5577      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5578 #ifdef DEBUG
5579         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5580 #endif
5581 C
5582         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5583      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5584      &  +pom1*pom_dt1+pom2*pom_dt2
5585 #ifdef DEBUG
5586         write(2,*), "de_dt = ", de_dt,de_dt_num
5587 #endif
5588 c
5589 C
5590        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5591        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5592        cosfac2xx=cosfac2*xx
5593        sinfac2yy=sinfac2*yy
5594        do k = 1,3
5595          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5596      &      vbld_inv(i+1)
5597          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5598      &      vbld_inv(i)
5599          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5600          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5601 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5602 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5603 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5604 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5605          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5606          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5607          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5608          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5609          dZZ_Ci1(k)=0.0d0
5610          dZZ_Ci(k)=0.0d0
5611          do j=1,3
5612            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5613            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5614          enddo
5615
5616          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5617          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5618          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5619 c
5620          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5621          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5622        enddo
5623
5624        do k=1,3
5625          dXX_Ctab(k,i)=dXX_Ci(k)
5626          dXX_C1tab(k,i)=dXX_Ci1(k)
5627          dYY_Ctab(k,i)=dYY_Ci(k)
5628          dYY_C1tab(k,i)=dYY_Ci1(k)
5629          dZZ_Ctab(k,i)=dZZ_Ci(k)
5630          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5631          dXX_XYZtab(k,i)=dXX_XYZ(k)
5632          dYY_XYZtab(k,i)=dYY_XYZ(k)
5633          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5634        enddo
5635
5636        do k = 1,3
5637 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5638 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5639 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5640 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5641 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5642 c     &    dt_dci(k)
5643 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5644 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5645          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5646      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5647          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5648      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5649          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5650      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5651        enddo
5652 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5653 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5654
5655 C to check gradient call subroutine check_grad
5656
5657     1 continue
5658       enddo
5659       return
5660       end
5661 c------------------------------------------------------------------------------
5662       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5663       implicit none
5664       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5665      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5666       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5667      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5668      &   + x(10)*yy*zz
5669       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5670      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5671      & + x(20)*yy*zz
5672       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5673      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5674      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5675      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5676      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5677      &  +x(40)*xx*yy*zz
5678       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5679      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5680      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5681      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5682      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5683      &  +x(60)*xx*yy*zz
5684       dsc_i   = 0.743d0+x(61)
5685       dp2_i   = 1.9d0+x(62)
5686       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5687      &          *(xx*cost2+yy*sint2))
5688       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5689      &          *(xx*cost2-yy*sint2))
5690       s1=(1+x(63))/(0.1d0 + dscp1)
5691       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5692       s2=(1+x(65))/(0.1d0 + dscp2)
5693       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5694       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5695      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5696       enesc=sumene
5697       return
5698       end
5699 #endif
5700 c------------------------------------------------------------------------------
5701       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5702 C
5703 C This procedure calculates two-body contact function g(rij) and its derivative:
5704 C
5705 C           eps0ij                                     !       x < -1
5706 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5707 C            0                                         !       x > 1
5708 C
5709 C where x=(rij-r0ij)/delta
5710 C
5711 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5712 C
5713       implicit none
5714       double precision rij,r0ij,eps0ij,fcont,fprimcont
5715       double precision x,x2,x4,delta
5716 c     delta=0.02D0*r0ij
5717 c      delta=0.2D0*r0ij
5718       x=(rij-r0ij)/delta
5719       if (x.lt.-1.0D0) then
5720         fcont=eps0ij
5721         fprimcont=0.0D0
5722       else if (x.le.1.0D0) then
5723         x2=x*x
5724         x4=x2*x2
5725         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5726         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5727       else
5728         fcont=0.0D0
5729         fprimcont=0.0D0
5730       endif
5731       return
5732       end
5733 c------------------------------------------------------------------------------
5734       subroutine splinthet(theti,delta,ss,ssder)
5735       implicit real*8 (a-h,o-z)
5736       include 'DIMENSIONS'
5737       include 'COMMON.VAR'
5738       include 'COMMON.GEO'
5739       thetup=pi-delta
5740       thetlow=delta
5741       if (theti.gt.pipol) then
5742         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5743       else
5744         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5745         ssder=-ssder
5746       endif
5747       return
5748       end
5749 c------------------------------------------------------------------------------
5750       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5751       implicit none
5752       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5753       double precision ksi,ksi2,ksi3,a1,a2,a3
5754       a1=fprim0*delta/(f1-f0)
5755       a2=3.0d0-2.0d0*a1
5756       a3=a1-2.0d0
5757       ksi=(x-x0)/delta
5758       ksi2=ksi*ksi
5759       ksi3=ksi2*ksi
5760       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5761       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5762       return
5763       end
5764 c------------------------------------------------------------------------------
5765       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5766       implicit none
5767       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5768       double precision ksi,ksi2,ksi3,a1,a2,a3
5769       ksi=(x-x0)/delta
5770       ksi2=ksi*ksi
5771       ksi3=ksi2*ksi
5772       a1=fprim0x*delta
5773       a2=3*(f1x-f0x)-2*fprim0x*delta
5774       a3=fprim0x*delta-2*(f1x-f0x)
5775       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5776       return
5777       end
5778 C-----------------------------------------------------------------------------
5779 #ifdef CRYST_TOR
5780 C-----------------------------------------------------------------------------
5781       subroutine etor(etors,edihcnstr)
5782       implicit real*8 (a-h,o-z)
5783       include 'DIMENSIONS'
5784       include 'COMMON.VAR'
5785       include 'COMMON.GEO'
5786       include 'COMMON.LOCAL'
5787       include 'COMMON.TORSION'
5788       include 'COMMON.INTERACT'
5789       include 'COMMON.DERIV'
5790       include 'COMMON.CHAIN'
5791       include 'COMMON.NAMES'
5792       include 'COMMON.IOUNITS'
5793       include 'COMMON.FFIELD'
5794       include 'COMMON.TORCNSTR'
5795       include 'COMMON.CONTROL'
5796       logical lprn
5797 C Set lprn=.true. for debugging
5798       lprn=.false.
5799 c      lprn=.true.
5800       etors=0.0D0
5801       do i=iphi_start,iphi_end
5802       etors_ii=0.0D0
5803         itori=itortyp(itype(i-2))
5804         itori1=itortyp(itype(i-1))
5805         phii=phi(i)
5806         gloci=0.0D0
5807 C Proline-Proline pair is a special case...
5808         if (itori.eq.3 .and. itori1.eq.3) then
5809           if (phii.gt.-dwapi3) then
5810             cosphi=dcos(3*phii)
5811             fac=1.0D0/(1.0D0-cosphi)
5812             etorsi=v1(1,3,3)*fac
5813             etorsi=etorsi+etorsi
5814             etors=etors+etorsi-v1(1,3,3)
5815             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5816             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5817           endif
5818           do j=1,3
5819             v1ij=v1(j+1,itori,itori1)
5820             v2ij=v2(j+1,itori,itori1)
5821             cosphi=dcos(j*phii)
5822             sinphi=dsin(j*phii)
5823             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5824             if (energy_dec) etors_ii=etors_ii+
5825      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5826             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5827           enddo
5828         else
5829           do j=1,nterm_old
5830             v1ij=v1(j,itori,itori1)
5831             v2ij=v2(j,itori,itori1)
5832             cosphi=dcos(j*phii)
5833             sinphi=dsin(j*phii)
5834             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5835             if (energy_dec) etors_ii=etors_ii+
5836      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5837             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5838           enddo
5839         endif
5840         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5841      &        'etor',i,etors_ii
5842         if (lprn)
5843      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5844      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5845      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5846         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5847         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5848       enddo
5849 ! 6/20/98 - dihedral angle constraints
5850       edihcnstr=0.0d0
5851       do i=1,ndih_constr
5852         itori=idih_constr(i)
5853         phii=phi(itori)
5854         difi=phii-phi0(i)
5855         if (difi.gt.drange(i)) then
5856           difi=difi-drange(i)
5857           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5858           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5859         else if (difi.lt.-drange(i)) then
5860           difi=difi+drange(i)
5861           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5862           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5863         endif
5864 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5865 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5866       enddo
5867 !      write (iout,*) 'edihcnstr',edihcnstr
5868       return
5869       end
5870 c------------------------------------------------------------------------------
5871 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5872       subroutine e_modeller(ehomology_constr)
5873       ehomology_constr=0.0d0
5874       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5875       return
5876       end
5877 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5878
5879 c------------------------------------------------------------------------------
5880       subroutine etor_d(etors_d)
5881       etors_d=0.0d0
5882       return
5883       end
5884 c----------------------------------------------------------------------------
5885 #else
5886       subroutine etor(etors,edihcnstr)
5887       implicit real*8 (a-h,o-z)
5888       include 'DIMENSIONS'
5889       include 'COMMON.VAR'
5890       include 'COMMON.GEO'
5891       include 'COMMON.LOCAL'
5892       include 'COMMON.TORSION'
5893       include 'COMMON.INTERACT'
5894       include 'COMMON.DERIV'
5895       include 'COMMON.CHAIN'
5896       include 'COMMON.NAMES'
5897       include 'COMMON.IOUNITS'
5898       include 'COMMON.FFIELD'
5899       include 'COMMON.TORCNSTR'
5900       include 'COMMON.CONTROL'
5901       logical lprn
5902 C Set lprn=.true. for debugging
5903       lprn=.false.
5904 c     lprn=.true.
5905       etors=0.0D0
5906       do i=iphi_start,iphi_end
5907       etors_ii=0.0D0
5908         itori=itortyp(itype(i-2))
5909         itori1=itortyp(itype(i-1))
5910         phii=phi(i)
5911         gloci=0.0D0
5912 C Regular cosine and sine terms
5913         do j=1,nterm(itori,itori1)
5914           v1ij=v1(j,itori,itori1)
5915           v2ij=v2(j,itori,itori1)
5916           cosphi=dcos(j*phii)
5917           sinphi=dsin(j*phii)
5918           etors=etors+v1ij*cosphi+v2ij*sinphi
5919           if (energy_dec) etors_ii=etors_ii+
5920      &                v1ij*cosphi+v2ij*sinphi
5921           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5922         enddo
5923 C Lorentz terms
5924 C                         v1
5925 C  E = SUM ----------------------------------- - v1
5926 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5927 C
5928         cosphi=dcos(0.5d0*phii)
5929         sinphi=dsin(0.5d0*phii)
5930         do j=1,nlor(itori,itori1)
5931           vl1ij=vlor1(j,itori,itori1)
5932           vl2ij=vlor2(j,itori,itori1)
5933           vl3ij=vlor3(j,itori,itori1)
5934           pom=vl2ij*cosphi+vl3ij*sinphi
5935           pom1=1.0d0/(pom*pom+1.0d0)
5936           etors=etors+vl1ij*pom1
5937           if (energy_dec) etors_ii=etors_ii+
5938      &                vl1ij*pom1
5939           pom=-pom*pom1*pom1
5940           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5941         enddo
5942 C Subtract the constant term
5943         etors=etors-v0(itori,itori1)
5944           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5945      &         'etor',i,etors_ii-v0(itori,itori1)
5946         if (lprn)
5947      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5948      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5949      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5950         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5951 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5952       enddo
5953 ! 6/20/98 - dihedral angle constraints
5954       edihcnstr=0.0d0
5955 c      do i=1,ndih_constr
5956       do i=idihconstr_start,idihconstr_end
5957         itori=idih_constr(i)
5958         phii=phi(itori)
5959         difi=pinorm(phii-phi0(i))
5960         if (difi.gt.drange(i)) then
5961           difi=difi-drange(i)
5962           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5963           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5964         else if (difi.lt.-drange(i)) then
5965           difi=difi+drange(i)
5966           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5967           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5968         else
5969           difi=0.0
5970         endif
5971 c        write (iout,*) "gloci", gloc(i-3,icg)
5972 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5973 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5974 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5975       enddo
5976 cd       write (iout,*) 'edihcnstr',edihcnstr
5977       return
5978       end
5979 c----------------------------------------------------------------------------
5980 c MODELLER restraint function
5981       subroutine e_modeller(ehomology_constr)
5982       implicit real*8 (a-h,o-z)
5983       include 'DIMENSIONS'
5984
5985       integer nnn, i, j, k, ki, irec, l
5986       integer katy, odleglosci, test7
5987       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
5988       real*8 Eval,Erot
5989       real*8 distance(max_template),distancek(max_template),
5990      &    min_odl,godl(max_template),dih_diff(max_template)
5991
5992 c
5993 c     FP - 30/10/2014 Temporary specifications for homology restraints
5994 c
5995       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
5996      &                 sgtheta
5997       double precision, dimension (maxres) :: guscdiff,usc_diff
5998       double precision, dimension (max_template) ::
5999      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6000      &           theta_diff
6001 c
6002
6003       include 'COMMON.SBRIDGE'
6004       include 'COMMON.CHAIN'
6005       include 'COMMON.GEO'
6006       include 'COMMON.DERIV'
6007       include 'COMMON.LOCAL'
6008       include 'COMMON.INTERACT'
6009       include 'COMMON.VAR'
6010       include 'COMMON.IOUNITS'
6011       include 'COMMON.MD'
6012       include 'COMMON.CONTROL'
6013 c
6014 c     From subroutine Econstr_back
6015 c
6016       include 'COMMON.NAMES'
6017       include 'COMMON.TIME1'
6018 c
6019
6020
6021       do i=1,19
6022         distancek(i)=9999999.9
6023       enddo
6024
6025
6026       odleg=0.0d0
6027
6028 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6029 c function)
6030 C AL 5/2/14 - Introduce list of restraints
6031 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6032 #ifdef DEBUG
6033       write(iout,*) "------- dist restrs start -------"
6034 #endif
6035       do ii = link_start_homo,link_end_homo
6036          i = ires_homo(ii)
6037          j = jres_homo(ii)
6038          dij=dist(i,j)
6039 c        write (iout,*) "dij(",i,j,") =",dij
6040          do k=1,constr_homology
6041 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
6042            if(.not.l_homo(k,ii)) cycle
6043            distance(k)=odl(k,ii)-dij
6044 c          write (iout,*) "distance(",k,") =",distance(k)
6045 c
6046 c          For Gaussian-type Urestr
6047 c
6048            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6049 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6050 c          write (iout,*) "distancek(",k,") =",distancek(k)
6051 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6052 c
6053 c          For Lorentzian-type Urestr
6054 c
6055            if (waga_dist.lt.0.0d0) then
6056               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6057               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6058      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
6059            endif
6060          enddo
6061
6062          min_odl=minval(distancek)
6063 c        write (iout,* )"min_odl",min_odl
6064 #ifdef DEBUG
6065          write (iout,*) "ij dij",i,j,dij
6066          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6067          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6068          write (iout,* )"min_odl",min_odl
6069 #endif
6070          odleg2=0.0d0
6071          do k=1,constr_homology
6072 c Nie wiem po co to liczycie jeszcze raz!
6073 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6074 c     &              (2*(sigma_odl(i,j,k))**2))
6075            if(.not.l_homo(k,ii)) cycle
6076            if (waga_dist.ge.0.0d0) then
6077 c
6078 c          For Gaussian-type Urestr
6079 c
6080             godl(k)=dexp(-distancek(k)+min_odl)
6081             odleg2=odleg2+godl(k)
6082 c
6083 c          For Lorentzian-type Urestr
6084 c
6085            else
6086             odleg2=odleg2+distancek(k)
6087            endif
6088
6089 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6090 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6091 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6092 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6093
6094          enddo
6095 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6096 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6097 #ifdef DEBUG
6098          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6099          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6100 #endif
6101            if (waga_dist.ge.0.0d0) then
6102 c
6103 c          For Gaussian-type Urestr
6104 c
6105               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6106 c
6107 c          For Lorentzian-type Urestr
6108 c
6109            else
6110               odleg=odleg+odleg2/constr_homology
6111            endif
6112 c
6113 c        write (iout,*) "odleg",odleg ! sum of -ln-s
6114 c Gradient
6115 c
6116 c          For Gaussian-type Urestr
6117 c
6118          if (waga_dist.ge.0.0d0) sum_godl=odleg2
6119          sum_sgodl=0.0d0
6120          do k=1,constr_homology
6121 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6122 c     &           *waga_dist)+min_odl
6123 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6124 c
6125          if(.not.l_homo(k,ii)) cycle
6126          if (waga_dist.ge.0.0d0) then
6127 c          For Gaussian-type Urestr
6128 c
6129            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6130 c
6131 c          For Lorentzian-type Urestr
6132 c
6133          else
6134            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
6135      &           sigma_odlir(k,ii)**2)**2)
6136          endif
6137            sum_sgodl=sum_sgodl+sgodl
6138
6139 c            sgodl2=sgodl2+sgodl
6140 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6141 c      write(iout,*) "constr_homology=",constr_homology
6142 c      write(iout,*) i, j, k, "TEST K"
6143          enddo
6144          if (waga_dist.ge.0.0d0) then
6145 c
6146 c          For Gaussian-type Urestr
6147 c
6148             grad_odl3=waga_homology(iset)*waga_dist
6149      &                *sum_sgodl/(sum_godl*dij)
6150 c
6151 c          For Lorentzian-type Urestr
6152 c
6153          else
6154 c Original grad expr modified by analogy w Gaussian-type Urestr grad
6155 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
6156             grad_odl3=-waga_homology(iset)*waga_dist*
6157      &                sum_sgodl/(constr_homology*dij)
6158          endif
6159 c
6160 c        grad_odl3=sum_sgodl/(sum_godl*dij)
6161
6162
6163 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6164 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6165 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6166
6167 ccc      write(iout,*) godl, sgodl, grad_odl3
6168
6169 c          grad_odl=grad_odl+grad_odl3
6170
6171          do jik=1,3
6172             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
6173 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6174 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6175 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6176             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
6177             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
6178 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6179 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6180 c         if (i.eq.25.and.j.eq.27) then
6181 c         write(iout,*) "jik",jik,"i",i,"j",j
6182 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
6183 c         write(iout,*) "grad_odl3",grad_odl3
6184 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
6185 c         write(iout,*) "ggodl",ggodl
6186 c         write(iout,*) "ghpbc(",jik,i,")",
6187 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
6188 c     &                 ghpbc(jik,j)
6189 c         endif
6190          enddo
6191 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
6192 ccc     & dLOG(odleg2),"-odleg=", -odleg
6193
6194       enddo ! ii-loop for dist
6195 #ifdef DEBUG
6196       write(iout,*) "------- dist restrs end -------"
6197 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
6198 c    &     waga_d.eq.1.0d0) call sum_gradient
6199 #endif
6200 c Pseudo-energy and gradient from dihedral-angle restraints from
6201 c homology templates
6202 c      write (iout,*) "End of distance loop"
6203 c      call flush(iout)
6204       kat=0.0d0
6205 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6206 #ifdef DEBUG
6207       write(iout,*) "------- dih restrs start -------"
6208       do i=idihconstr_start_homo,idihconstr_end_homo
6209         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
6210       enddo
6211 #endif
6212       do i=idihconstr_start_homo,idihconstr_end_homo
6213         kat2=0.0d0
6214 c        betai=beta(i,i+1,i+2,i+3)
6215         betai = phi(i+3)
6216 c       write (iout,*) "betai =",betai
6217         do k=1,constr_homology
6218           dih_diff(k)=pinorm(dih(k,i)-betai)
6219 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
6220 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6221 c     &                                   -(6.28318-dih_diff(i,k))
6222 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6223 c     &                                   6.28318+dih_diff(i,k)
6224
6225           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
6226 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
6227           gdih(k)=dexp(kat3)
6228           kat2=kat2+gdih(k)
6229 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
6230 c          write(*,*)""
6231         enddo
6232 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
6233 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
6234 #ifdef DEBUG
6235         write (iout,*) "i",i," betai",betai," kat2",kat2
6236         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6237 #endif
6238         if (kat2.le.1.0d-14) cycle
6239         kat=kat-dLOG(kat2/constr_homology)
6240 c       write (iout,*) "kat",kat ! sum of -ln-s
6241
6242 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6243 ccc     & dLOG(kat2), "-kat=", -kat
6244
6245 c ----------------------------------------------------------------------
6246 c Gradient
6247 c ----------------------------------------------------------------------
6248
6249         sum_gdih=kat2
6250         sum_sgdih=0.0d0
6251         do k=1,constr_homology
6252           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
6253 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
6254           sum_sgdih=sum_sgdih+sgdih
6255         enddo
6256 c       grad_dih3=sum_sgdih/sum_gdih
6257         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
6258
6259 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6260 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6261 ccc     & gloc(nphi+i-3,icg)
6262         gloc(i,icg)=gloc(i,icg)+grad_dih3
6263 c        if (i.eq.25) then
6264 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
6265 c        endif
6266 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6267 ccc     & gloc(nphi+i-3,icg)
6268
6269       enddo ! i-loop for dih
6270 #ifdef DEBUG
6271       write(iout,*) "------- dih restrs end -------"
6272 #endif
6273
6274 c Pseudo-energy and gradient for theta angle restraints from
6275 c homology templates
6276 c FP 01/15 - inserted from econstr_local_test.F, loop structure
6277 c adapted
6278
6279 c
6280 c     For constr_homology reference structures (FP)
6281 c
6282 c     Uconst_back_tot=0.0d0
6283       Eval=0.0d0
6284       Erot=0.0d0
6285 c     Econstr_back legacy
6286       do i=1,nres
6287 c     do i=ithet_start,ithet_end
6288        dutheta(i)=0.0d0
6289 c     enddo
6290 c     do i=loc_start,loc_end
6291         do j=1,3
6292           duscdiff(j,i)=0.0d0
6293           duscdiffx(j,i)=0.0d0
6294         enddo
6295       enddo
6296 c
6297 c     do iref=1,nref
6298 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
6299 c     write (iout,*) "waga_theta",waga_theta
6300       if (waga_theta.gt.0.0d0) then
6301 #ifdef DEBUG
6302       write (iout,*) "usampl",usampl
6303       write(iout,*) "------- theta restrs start -------"
6304 c     do i=ithet_start,ithet_end
6305 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
6306 c     enddo
6307 #endif
6308 c     write (iout,*) "maxres",maxres,"nres",nres
6309
6310       do i=ithet_start,ithet_end
6311 c
6312 c     do i=1,nfrag_back
6313 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
6314 c
6315 c Deviation of theta angles wrt constr_homology ref structures
6316 c
6317         utheta_i=0.0d0 ! argument of Gaussian for single k
6318         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6319 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
6320 c       over residues in a fragment
6321 c       write (iout,*) "theta(",i,")=",theta(i)
6322         do k=1,constr_homology
6323 c
6324 c         dtheta_i=theta(j)-thetaref(j,iref)
6325 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
6326           theta_diff(k)=thetatpl(k,i)-theta(i)
6327 c
6328           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
6329 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
6330           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
6331           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
6332 c         Gradient for single Gaussian restraint in subr Econstr_back
6333 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
6334 c
6335         enddo
6336 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
6337 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
6338
6339 c
6340 c         Gradient for multiple Gaussian restraint
6341         sum_gtheta=gutheta_i
6342         sum_sgtheta=0.0d0
6343         do k=1,constr_homology
6344 c        New generalized expr for multiple Gaussian from Econstr_back
6345          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
6346 c
6347 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
6348           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
6349         enddo
6350 c       Final value of gradient using same var as in Econstr_back
6351         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
6352      &      +sum_sgtheta/sum_gtheta*waga_theta
6353      &               *waga_homology(iset)
6354 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
6355 c     &               *waga_homology(iset)
6356 c       dutheta(i)=sum_sgtheta/sum_gtheta
6357 c
6358 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
6359         Eval=Eval-dLOG(gutheta_i/constr_homology)
6360 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
6361 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
6362 c       Uconst_back=Uconst_back+utheta(i)
6363       enddo ! (i-loop for theta)
6364 #ifdef DEBUG
6365       write(iout,*) "------- theta restrs end -------"
6366 #endif
6367       endif
6368 c
6369 c Deviation of local SC geometry
6370 c
6371 c Separation of two i-loops (instructed by AL - 11/3/2014)
6372 c
6373 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
6374 c     write (iout,*) "waga_d",waga_d
6375
6376 #ifdef DEBUG
6377       write(iout,*) "------- SC restrs start -------"
6378       write (iout,*) "Initial duscdiff,duscdiffx"
6379       do i=loc_start,loc_end
6380         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
6381      &                 (duscdiffx(jik,i),jik=1,3)
6382       enddo
6383 #endif
6384       do i=loc_start,loc_end
6385         usc_diff_i=0.0d0 ! argument of Gaussian for single k
6386         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6387 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
6388 c       write(iout,*) "xxtab, yytab, zztab"
6389 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
6390         do k=1,constr_homology
6391 c
6392           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6393 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
6394           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6395           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6396 c         write(iout,*) "dxx, dyy, dzz"
6397 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6398 c
6399           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
6400 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
6401 c         uscdiffk(k)=usc_diff(i)
6402           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
6403           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
6404 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
6405 c     &      xxref(j),yyref(j),zzref(j)
6406         enddo
6407 c
6408 c       Gradient
6409 c
6410 c       Generalized expression for multiple Gaussian acc to that for a single
6411 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
6412 c
6413 c       Original implementation
6414 c       sum_guscdiff=guscdiff(i)
6415 c
6416 c       sum_sguscdiff=0.0d0
6417 c       do k=1,constr_homology
6418 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
6419 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
6420 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
6421 c       enddo
6422 c
6423 c       Implementation of new expressions for gradient (Jan. 2015)
6424 c
6425 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
6426         do k=1,constr_homology
6427 c
6428 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
6429 c       before. Now the drivatives should be correct
6430 c
6431           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6432 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
6433           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6434           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6435 c
6436 c         New implementation
6437 c
6438           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
6439      &                 sigma_d(k,i) ! for the grad wrt r'
6440 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
6441 c
6442 c
6443 c        New implementation
6444          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
6445          do jik=1,3
6446             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
6447      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
6448      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
6449             duscdiff(jik,i)=duscdiff(jik,i)+
6450      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
6451      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
6452             duscdiffx(jik,i)=duscdiffx(jik,i)+
6453      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
6454      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
6455 c
6456 #ifdef DEBUG
6457              write(iout,*) "jik",jik,"i",i
6458              write(iout,*) "dxx, dyy, dzz"
6459              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6460              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
6461 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
6462 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
6463 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
6464 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
6465 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
6466 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
6467 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
6468 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
6469 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
6470 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
6471 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
6472 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
6473 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
6474 c            endif
6475 #endif
6476          enddo
6477         enddo
6478 c
6479 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
6480 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
6481 c
6482 c        write (iout,*) i," uscdiff",uscdiff(i)
6483 c
6484 c Put together deviations from local geometry
6485
6486 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
6487 c      &            wfrag_back(3,i,iset)*uscdiff(i)
6488         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
6489 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
6490 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
6491 c       Uconst_back=Uconst_back+usc_diff(i)
6492 c
6493 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
6494 c
6495 c     New implment: multiplied by sum_sguscdiff
6496 c
6497
6498       enddo ! (i-loop for dscdiff)
6499
6500 c      endif
6501
6502 #ifdef DEBUG
6503       write(iout,*) "------- SC restrs end -------"
6504         write (iout,*) "------ After SC loop in e_modeller ------"
6505         do i=loc_start,loc_end
6506          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
6507          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
6508         enddo
6509       if (waga_theta.eq.1.0d0) then
6510       write (iout,*) "in e_modeller after SC restr end: dutheta"
6511       do i=ithet_start,ithet_end
6512         write (iout,*) i,dutheta(i)
6513       enddo
6514       endif
6515       if (waga_d.eq.1.0d0) then
6516       write (iout,*) "e_modeller after SC loop: duscdiff/x"
6517       do i=1,nres
6518         write (iout,*) i,(duscdiff(j,i),j=1,3)
6519         write (iout,*) i,(duscdiffx(j,i),j=1,3)
6520       enddo
6521       endif
6522 #endif
6523
6524 c Total energy from homology restraints
6525 #ifdef DEBUG
6526       write (iout,*) "odleg",odleg," kat",kat
6527 #endif
6528 c
6529 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
6530 c
6531 c     ehomology_constr=odleg+kat
6532 c
6533 c     For Lorentzian-type Urestr
6534 c
6535
6536       if (waga_dist.ge.0.0d0) then
6537 c
6538 c          For Gaussian-type Urestr
6539 c
6540         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
6541      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6542 c     write (iout,*) "ehomology_constr=",ehomology_constr
6543       else
6544 c
6545 c          For Lorentzian-type Urestr
6546 c
6547         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
6548      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6549 c     write (iout,*) "ehomology_constr=",ehomology_constr
6550       endif
6551 #ifdef DEBUG
6552       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
6553      & "Eval",waga_theta,eval,
6554      &   "Erot",waga_d,Erot
6555       write (iout,*) "ehomology_constr",ehomology_constr
6556 #endif
6557       return
6558 c
6559 c FP 01/15 end
6560 c
6561   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6562   747 format(a12,i4,i4,i4,f8.3,f8.3)
6563   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6564   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6565   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6566      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6567       end
6568
6569 c------------------------------------------------------------------------------
6570       subroutine etor_d(etors_d)
6571 C 6/23/01 Compute double torsional energy
6572       implicit real*8 (a-h,o-z)
6573       include 'DIMENSIONS'
6574       include 'COMMON.VAR'
6575       include 'COMMON.GEO'
6576       include 'COMMON.LOCAL'
6577       include 'COMMON.TORSION'
6578       include 'COMMON.INTERACT'
6579       include 'COMMON.DERIV'
6580       include 'COMMON.CHAIN'
6581       include 'COMMON.NAMES'
6582       include 'COMMON.IOUNITS'
6583       include 'COMMON.FFIELD'
6584       include 'COMMON.TORCNSTR'
6585       logical lprn
6586 C Set lprn=.true. for debugging
6587       lprn=.false.
6588 c     lprn=.true.
6589       etors_d=0.0D0
6590       do i=iphid_start,iphid_end
6591         itori=itortyp(itype(i-2))
6592         itori1=itortyp(itype(i-1))
6593         itori2=itortyp(itype(i))
6594         phii=phi(i)
6595         phii1=phi(i+1)
6596         gloci1=0.0D0
6597         gloci2=0.0D0
6598         do j=1,ntermd_1(itori,itori1,itori2)
6599           v1cij=v1c(1,j,itori,itori1,itori2)
6600           v1sij=v1s(1,j,itori,itori1,itori2)
6601           v2cij=v1c(2,j,itori,itori1,itori2)
6602           v2sij=v1s(2,j,itori,itori1,itori2)
6603           cosphi1=dcos(j*phii)
6604           sinphi1=dsin(j*phii)
6605           cosphi2=dcos(j*phii1)
6606           sinphi2=dsin(j*phii1)
6607           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6608      &     v2cij*cosphi2+v2sij*sinphi2
6609           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6610           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6611         enddo
6612         do k=2,ntermd_2(itori,itori1,itori2)
6613           do l=1,k-1
6614             v1cdij = v2c(k,l,itori,itori1,itori2)
6615             v2cdij = v2c(l,k,itori,itori1,itori2)
6616             v1sdij = v2s(k,l,itori,itori1,itori2)
6617             v2sdij = v2s(l,k,itori,itori1,itori2)
6618             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6619             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6620             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6621             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6622             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6623      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6624             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6625      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6626             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6627      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6628           enddo
6629         enddo
6630         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6631         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6632 c        write (iout,*) "gloci", gloc(i-3,icg)
6633       enddo
6634       return
6635       end
6636 #endif
6637 c------------------------------------------------------------------------------
6638       subroutine eback_sc_corr(esccor)
6639 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6640 c        conformational states; temporarily implemented as differences
6641 c        between UNRES torsional potentials (dependent on three types of
6642 c        residues) and the torsional potentials dependent on all 20 types
6643 c        of residues computed from AM1  energy surfaces of terminally-blocked
6644 c        amino-acid residues.
6645       implicit real*8 (a-h,o-z)
6646       include 'DIMENSIONS'
6647       include 'COMMON.VAR'
6648       include 'COMMON.GEO'
6649       include 'COMMON.LOCAL'
6650       include 'COMMON.TORSION'
6651       include 'COMMON.SCCOR'
6652       include 'COMMON.INTERACT'
6653       include 'COMMON.DERIV'
6654       include 'COMMON.CHAIN'
6655       include 'COMMON.NAMES'
6656       include 'COMMON.IOUNITS'
6657       include 'COMMON.FFIELD'
6658       include 'COMMON.CONTROL'
6659       logical lprn
6660 C Set lprn=.true. for debugging
6661       lprn=.false.
6662 c      lprn=.true.
6663 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6664       esccor=0.0D0
6665       do i=itau_start,itau_end
6666         esccor_ii=0.0D0
6667         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6668         isccori=isccortyp(itype(i-2))
6669         isccori1=isccortyp(itype(i-1))
6670         phii=phi(i)
6671 cccc  Added 9 May 2012
6672 cc Tauangle is torsional engle depending on the value of first digit
6673 c(see comment below)
6674 cc Omicron is flat angle depending on the value of first digit
6675 c(see comment below)
6676
6677
6678         do intertyp=1,3 !intertyp
6679 cc Added 09 May 2012 (Adasko)
6680 cc  Intertyp means interaction type of backbone mainchain correlation:
6681 c   1 = SC...Ca...Ca...Ca
6682 c   2 = Ca...Ca...Ca...SC
6683 c   3 = SC...Ca...Ca...SCi
6684         gloci=0.0D0
6685         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6686      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6687      &      (itype(i-1).eq.21)))
6688      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6689      &     .or.(itype(i-2).eq.21)))
6690      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6691      &      (itype(i-1).eq.21)))) cycle
6692         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6693         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6694      & cycle
6695         do j=1,nterm_sccor(isccori,isccori1)
6696           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6697           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6698           cosphi=dcos(j*tauangle(intertyp,i))
6699           sinphi=dsin(j*tauangle(intertyp,i))
6700           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6701           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6702         enddo
6703         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6704 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6705 c     &gloc_sc(intertyp,i-3,icg)
6706         if (lprn)
6707      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6708      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6709      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6710      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6711         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6712        enddo !intertyp
6713       enddo
6714 c        do i=1,nres
6715 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6716 c        enddo
6717       return
6718       end
6719 c----------------------------------------------------------------------------
6720       subroutine multibody(ecorr)
6721 C This subroutine calculates multi-body contributions to energy following
6722 C the idea of Skolnick et al. If side chains I and J make a contact and
6723 C at the same time side chains I+1 and J+1 make a contact, an extra
6724 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6725       implicit real*8 (a-h,o-z)
6726       include 'DIMENSIONS'
6727       include 'COMMON.IOUNITS'
6728       include 'COMMON.DERIV'
6729       include 'COMMON.INTERACT'
6730       include 'COMMON.CONTACTS'
6731       double precision gx(3),gx1(3)
6732       logical lprn
6733
6734 C Set lprn=.true. for debugging
6735       lprn=.false.
6736
6737       if (lprn) then
6738         write (iout,'(a)') 'Contact function values:'
6739         do i=nnt,nct-2
6740           write (iout,'(i2,20(1x,i2,f10.5))')
6741      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6742         enddo
6743       endif
6744       ecorr=0.0D0
6745       do i=nnt,nct
6746         do j=1,3
6747           gradcorr(j,i)=0.0D0
6748           gradxorr(j,i)=0.0D0
6749         enddo
6750       enddo
6751       do i=nnt,nct-2
6752
6753         DO ISHIFT = 3,4
6754
6755         i1=i+ishift
6756         num_conti=num_cont(i)
6757         num_conti1=num_cont(i1)
6758         do jj=1,num_conti
6759           j=jcont(jj,i)
6760           do kk=1,num_conti1
6761             j1=jcont(kk,i1)
6762             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6763 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6764 cd   &                   ' ishift=',ishift
6765 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6766 C The system gains extra energy.
6767               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6768             endif   ! j1==j+-ishift
6769           enddo     ! kk
6770         enddo       ! jj
6771
6772         ENDDO ! ISHIFT
6773
6774       enddo         ! i
6775       return
6776       end
6777 c------------------------------------------------------------------------------
6778       double precision function esccorr(i,j,k,l,jj,kk)
6779       implicit real*8 (a-h,o-z)
6780       include 'DIMENSIONS'
6781       include 'COMMON.IOUNITS'
6782       include 'COMMON.DERIV'
6783       include 'COMMON.INTERACT'
6784       include 'COMMON.CONTACTS'
6785       double precision gx(3),gx1(3)
6786       logical lprn
6787       lprn=.false.
6788       eij=facont(jj,i)
6789       ekl=facont(kk,k)
6790 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6791 C Calculate the multi-body contribution to energy.
6792 C Calculate multi-body contributions to the gradient.
6793 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6794 cd   & k,l,(gacont(m,kk,k),m=1,3)
6795       do m=1,3
6796         gx(m) =ekl*gacont(m,jj,i)
6797         gx1(m)=eij*gacont(m,kk,k)
6798         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6799         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6800         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6801         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6802       enddo
6803       do m=i,j-1
6804         do ll=1,3
6805           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6806         enddo
6807       enddo
6808       do m=k,l-1
6809         do ll=1,3
6810           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6811         enddo
6812       enddo
6813       esccorr=-eij*ekl
6814       return
6815       end
6816 c------------------------------------------------------------------------------
6817       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6818 C This subroutine calculates multi-body contributions to hydrogen-bonding
6819       implicit real*8 (a-h,o-z)
6820       include 'DIMENSIONS'
6821       include 'COMMON.IOUNITS'
6822 #ifdef MPI
6823       include "mpif.h"
6824       parameter (max_cont=maxconts)
6825       parameter (max_dim=26)
6826       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6827       double precision zapas(max_dim,maxconts,max_fg_procs),
6828      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6829       common /przechowalnia/ zapas
6830       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6831      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6832 #endif
6833       include 'COMMON.SETUP'
6834       include 'COMMON.FFIELD'
6835       include 'COMMON.DERIV'
6836       include 'COMMON.INTERACT'
6837       include 'COMMON.CONTACTS'
6838       include 'COMMON.CONTROL'
6839       include 'COMMON.LOCAL'
6840       double precision gx(3),gx1(3),time00
6841       logical lprn,ldone
6842
6843 C Set lprn=.true. for debugging
6844       lprn=.false.
6845 #ifdef MPI
6846       n_corr=0
6847       n_corr1=0
6848       if (nfgtasks.le.1) goto 30
6849       if (lprn) then
6850         write (iout,'(a)') 'Contact function values before RECEIVE:'
6851         do i=nnt,nct-2
6852           write (iout,'(2i3,50(1x,i2,f5.2))')
6853      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6854      &    j=1,num_cont_hb(i))
6855         enddo
6856       endif
6857       call flush(iout)
6858       do i=1,ntask_cont_from
6859         ncont_recv(i)=0
6860       enddo
6861       do i=1,ntask_cont_to
6862         ncont_sent(i)=0
6863       enddo
6864 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6865 c     & ntask_cont_to
6866 C Make the list of contacts to send to send to other procesors
6867 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6868 c      call flush(iout)
6869       do i=iturn3_start,iturn3_end
6870 c        write (iout,*) "make contact list turn3",i," num_cont",
6871 c     &    num_cont_hb(i)
6872         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6873       enddo
6874       do i=iturn4_start,iturn4_end
6875 c        write (iout,*) "make contact list turn4",i," num_cont",
6876 c     &   num_cont_hb(i)
6877         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6878       enddo
6879       do ii=1,nat_sent
6880         i=iat_sent(ii)
6881 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6882 c     &    num_cont_hb(i)
6883         do j=1,num_cont_hb(i)
6884         do k=1,4
6885           jjc=jcont_hb(j,i)
6886           iproc=iint_sent_local(k,jjc,ii)
6887 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6888           if (iproc.gt.0) then
6889             ncont_sent(iproc)=ncont_sent(iproc)+1
6890             nn=ncont_sent(iproc)
6891             zapas(1,nn,iproc)=i
6892             zapas(2,nn,iproc)=jjc
6893             zapas(3,nn,iproc)=facont_hb(j,i)
6894             zapas(4,nn,iproc)=ees0p(j,i)
6895             zapas(5,nn,iproc)=ees0m(j,i)
6896             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6897             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6898             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6899             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6900             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6901             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6902             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6903             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6904             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6905             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6906             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6907             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6908             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6909             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6910             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6911             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6912             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6913             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6914             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6915             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6916             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6917           endif
6918         enddo
6919         enddo
6920       enddo
6921       if (lprn) then
6922       write (iout,*)
6923      &  "Numbers of contacts to be sent to other processors",
6924      &  (ncont_sent(i),i=1,ntask_cont_to)
6925       write (iout,*) "Contacts sent"
6926       do ii=1,ntask_cont_to
6927         nn=ncont_sent(ii)
6928         iproc=itask_cont_to(ii)
6929         write (iout,*) nn," contacts to processor",iproc,
6930      &   " of CONT_TO_COMM group"
6931         do i=1,nn
6932           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6933         enddo
6934       enddo
6935       call flush(iout)
6936       endif
6937       CorrelType=477
6938       CorrelID=fg_rank+1
6939       CorrelType1=478
6940       CorrelID1=nfgtasks+fg_rank+1
6941       ireq=0
6942 C Receive the numbers of needed contacts from other processors
6943       do ii=1,ntask_cont_from
6944         iproc=itask_cont_from(ii)
6945         ireq=ireq+1
6946         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6947      &    FG_COMM,req(ireq),IERR)
6948       enddo
6949 c      write (iout,*) "IRECV ended"
6950 c      call flush(iout)
6951 C Send the number of contacts needed by other processors
6952       do ii=1,ntask_cont_to
6953         iproc=itask_cont_to(ii)
6954         ireq=ireq+1
6955         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6956      &    FG_COMM,req(ireq),IERR)
6957       enddo
6958 c      write (iout,*) "ISEND ended"
6959 c      write (iout,*) "number of requests (nn)",ireq
6960       call flush(iout)
6961       if (ireq.gt.0)
6962      &  call MPI_Waitall(ireq,req,status_array,ierr)
6963 c      write (iout,*)
6964 c     &  "Numbers of contacts to be received from other processors",
6965 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6966 c      call flush(iout)
6967 C Receive contacts
6968       ireq=0
6969       do ii=1,ntask_cont_from
6970         iproc=itask_cont_from(ii)
6971         nn=ncont_recv(ii)
6972 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6973 c     &   " of CONT_TO_COMM group"
6974         call flush(iout)
6975         if (nn.gt.0) then
6976           ireq=ireq+1
6977           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6978      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6979 c          write (iout,*) "ireq,req",ireq,req(ireq)
6980         endif
6981       enddo
6982 C Send the contacts to processors that need them
6983       do ii=1,ntask_cont_to
6984         iproc=itask_cont_to(ii)
6985         nn=ncont_sent(ii)
6986 c        write (iout,*) nn," contacts to processor",iproc,
6987 c     &   " of CONT_TO_COMM group"
6988         if (nn.gt.0) then
6989           ireq=ireq+1
6990           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6991      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6992 c          write (iout,*) "ireq,req",ireq,req(ireq)
6993 c          do i=1,nn
6994 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6995 c          enddo
6996         endif
6997       enddo
6998 c      write (iout,*) "number of requests (contacts)",ireq
6999 c      write (iout,*) "req",(req(i),i=1,4)
7000 c      call flush(iout)
7001       if (ireq.gt.0)
7002      & call MPI_Waitall(ireq,req,status_array,ierr)
7003       do iii=1,ntask_cont_from
7004         iproc=itask_cont_from(iii)
7005         nn=ncont_recv(iii)
7006         if (lprn) then
7007         write (iout,*) "Received",nn," contacts from processor",iproc,
7008      &   " of CONT_FROM_COMM group"
7009         call flush(iout)
7010         do i=1,nn
7011           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7012         enddo
7013         call flush(iout)
7014         endif
7015         do i=1,nn
7016           ii=zapas_recv(1,i,iii)
7017 c Flag the received contacts to prevent double-counting
7018           jj=-zapas_recv(2,i,iii)
7019 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7020 c          call flush(iout)
7021           nnn=num_cont_hb(ii)+1
7022           num_cont_hb(ii)=nnn
7023           jcont_hb(nnn,ii)=jj
7024           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7025           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7026           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7027           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7028           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7029           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7030           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7031           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7032           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7033           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7034           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7035           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7036           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7037           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7038           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7039           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7040           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7041           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7042           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7043           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7044           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7045           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7046           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7047           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7048         enddo
7049       enddo
7050       call flush(iout)
7051       if (lprn) then
7052         write (iout,'(a)') 'Contact function values after receive:'
7053         do i=nnt,nct-2
7054           write (iout,'(2i3,50(1x,i3,f5.2))')
7055      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7056      &    j=1,num_cont_hb(i))
7057         enddo
7058         call flush(iout)
7059       endif
7060    30 continue
7061 #endif
7062       if (lprn) then
7063         write (iout,'(a)') 'Contact function values:'
7064         do i=nnt,nct-2
7065           write (iout,'(2i3,50(1x,i3,f5.2))')
7066      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7067      &    j=1,num_cont_hb(i))
7068         enddo
7069       endif
7070       ecorr=0.0D0
7071 C Remove the loop below after debugging !!!
7072       do i=nnt,nct
7073         do j=1,3
7074           gradcorr(j,i)=0.0D0
7075           gradxorr(j,i)=0.0D0
7076         enddo
7077       enddo
7078 C Calculate the local-electrostatic correlation terms
7079       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7080         i1=i+1
7081         num_conti=num_cont_hb(i)
7082         num_conti1=num_cont_hb(i+1)
7083         do jj=1,num_conti
7084           j=jcont_hb(jj,i)
7085           jp=iabs(j)
7086           do kk=1,num_conti1
7087             j1=jcont_hb(kk,i1)
7088             jp1=iabs(j1)
7089 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7090 c     &         ' jj=',jj,' kk=',kk
7091             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7092      &          .or. j.lt.0 .and. j1.gt.0) .and.
7093      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7094 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7095 C The system gains extra energy.
7096               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7097               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7098      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7099               n_corr=n_corr+1
7100             else if (j1.eq.j) then
7101 C Contacts I-J and I-(J+1) occur simultaneously.
7102 C The system loses extra energy.
7103 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7104             endif
7105           enddo ! kk
7106           do kk=1,num_conti
7107             j1=jcont_hb(kk,i)
7108 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7109 c    &         ' jj=',jj,' kk=',kk
7110             if (j1.eq.j+1) then
7111 C Contacts I-J and (I+1)-J occur simultaneously.
7112 C The system loses extra energy.
7113 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7114             endif ! j1==j+1
7115           enddo ! kk
7116         enddo ! jj
7117       enddo ! i
7118       return
7119       end
7120 c------------------------------------------------------------------------------
7121       subroutine add_hb_contact(ii,jj,itask)
7122       implicit real*8 (a-h,o-z)
7123       include "DIMENSIONS"
7124       include "COMMON.IOUNITS"
7125       integer max_cont
7126       integer max_dim
7127       parameter (max_cont=maxconts)
7128       parameter (max_dim=26)
7129       include "COMMON.CONTACTS"
7130       double precision zapas(max_dim,maxconts,max_fg_procs),
7131      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7132       common /przechowalnia/ zapas
7133       integer i,j,ii,jj,iproc,itask(4),nn
7134 c      write (iout,*) "itask",itask
7135       do i=1,2
7136         iproc=itask(i)
7137         if (iproc.gt.0) then
7138           do j=1,num_cont_hb(ii)
7139             jjc=jcont_hb(j,ii)
7140 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7141             if (jjc.eq.jj) then
7142               ncont_sent(iproc)=ncont_sent(iproc)+1
7143               nn=ncont_sent(iproc)
7144               zapas(1,nn,iproc)=ii
7145               zapas(2,nn,iproc)=jjc
7146               zapas(3,nn,iproc)=facont_hb(j,ii)
7147               zapas(4,nn,iproc)=ees0p(j,ii)
7148               zapas(5,nn,iproc)=ees0m(j,ii)
7149               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7150               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7151               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7152               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7153               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7154               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7155               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7156               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7157               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7158               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7159               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7160               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7161               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7162               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7163               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7164               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7165               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7166               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7167               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7168               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7169               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7170               exit
7171             endif
7172           enddo
7173         endif
7174       enddo
7175       return
7176       end
7177 c------------------------------------------------------------------------------
7178       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7179      &  n_corr1)
7180 C This subroutine calculates multi-body contributions to hydrogen-bonding
7181       implicit real*8 (a-h,o-z)
7182       include 'DIMENSIONS'
7183       include 'COMMON.IOUNITS'
7184 #ifdef MPI
7185       include "mpif.h"
7186       parameter (max_cont=maxconts)
7187       parameter (max_dim=70)
7188       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
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 status(MPI_STATUS_SIZE),req(maxconts*2),
7193      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7194 #endif
7195       include 'COMMON.SETUP'
7196       include 'COMMON.FFIELD'
7197       include 'COMMON.DERIV'
7198       include 'COMMON.LOCAL'
7199       include 'COMMON.INTERACT'
7200       include 'COMMON.CONTACTS'
7201       include 'COMMON.CHAIN'
7202       include 'COMMON.CONTROL'
7203       double precision gx(3),gx1(3)
7204       integer num_cont_hb_old(maxres)
7205       logical lprn,ldone
7206       double precision eello4,eello5,eelo6,eello_turn6
7207       external eello4,eello5,eello6,eello_turn6
7208 C Set lprn=.true. for debugging
7209       lprn=.false.
7210       eturn6=0.0d0
7211 #ifdef MPI
7212       do i=1,nres
7213         num_cont_hb_old(i)=num_cont_hb(i)
7214       enddo
7215       n_corr=0
7216       n_corr1=0
7217       if (nfgtasks.le.1) goto 30
7218       if (lprn) then
7219         write (iout,'(a)') 'Contact function values before RECEIVE:'
7220         do i=nnt,nct-2
7221           write (iout,'(2i3,50(1x,i2,f5.2))')
7222      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7223      &    j=1,num_cont_hb(i))
7224         enddo
7225       endif
7226       call flush(iout)
7227       do i=1,ntask_cont_from
7228         ncont_recv(i)=0
7229       enddo
7230       do i=1,ntask_cont_to
7231         ncont_sent(i)=0
7232       enddo
7233 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7234 c     & ntask_cont_to
7235 C Make the list of contacts to send to send to other procesors
7236       do i=iturn3_start,iturn3_end
7237 c        write (iout,*) "make contact list turn3",i," num_cont",
7238 c     &    num_cont_hb(i)
7239         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7240       enddo
7241       do i=iturn4_start,iturn4_end
7242 c        write (iout,*) "make contact list turn4",i," num_cont",
7243 c     &   num_cont_hb(i)
7244         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7245       enddo
7246       do ii=1,nat_sent
7247         i=iat_sent(ii)
7248 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7249 c     &    num_cont_hb(i)
7250         do j=1,num_cont_hb(i)
7251         do k=1,4
7252           jjc=jcont_hb(j,i)
7253           iproc=iint_sent_local(k,jjc,ii)
7254 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7255           if (iproc.ne.0) then
7256             ncont_sent(iproc)=ncont_sent(iproc)+1
7257             nn=ncont_sent(iproc)
7258             zapas(1,nn,iproc)=i
7259             zapas(2,nn,iproc)=jjc
7260             zapas(3,nn,iproc)=d_cont(j,i)
7261             ind=3
7262             do kk=1,3
7263               ind=ind+1
7264               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7265             enddo
7266             do kk=1,2
7267               do ll=1,2
7268                 ind=ind+1
7269                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7270               enddo
7271             enddo
7272             do jj=1,5
7273               do kk=1,3
7274                 do ll=1,2
7275                   do mm=1,2
7276                     ind=ind+1
7277                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7278                   enddo
7279                 enddo
7280               enddo
7281             enddo
7282           endif
7283         enddo
7284         enddo
7285       enddo
7286       if (lprn) then
7287       write (iout,*)
7288      &  "Numbers of contacts to be sent to other processors",
7289      &  (ncont_sent(i),i=1,ntask_cont_to)
7290       write (iout,*) "Contacts sent"
7291       do ii=1,ntask_cont_to
7292         nn=ncont_sent(ii)
7293         iproc=itask_cont_to(ii)
7294         write (iout,*) nn," contacts to processor",iproc,
7295      &   " of CONT_TO_COMM group"
7296         do i=1,nn
7297           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7298         enddo
7299       enddo
7300       call flush(iout)
7301       endif
7302       CorrelType=477
7303       CorrelID=fg_rank+1
7304       CorrelType1=478
7305       CorrelID1=nfgtasks+fg_rank+1
7306       ireq=0
7307 C Receive the numbers of needed contacts from other processors
7308       do ii=1,ntask_cont_from
7309         iproc=itask_cont_from(ii)
7310         ireq=ireq+1
7311         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7312      &    FG_COMM,req(ireq),IERR)
7313       enddo
7314 c      write (iout,*) "IRECV ended"
7315 c      call flush(iout)
7316 C Send the number of contacts needed by other processors
7317       do ii=1,ntask_cont_to
7318         iproc=itask_cont_to(ii)
7319         ireq=ireq+1
7320         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7321      &    FG_COMM,req(ireq),IERR)
7322       enddo
7323 c      write (iout,*) "ISEND ended"
7324 c      write (iout,*) "number of requests (nn)",ireq
7325       call flush(iout)
7326       if (ireq.gt.0)
7327      &  call MPI_Waitall(ireq,req,status_array,ierr)
7328 c      write (iout,*)
7329 c     &  "Numbers of contacts to be received from other processors",
7330 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7331 c      call flush(iout)
7332 C Receive contacts
7333       ireq=0
7334       do ii=1,ntask_cont_from
7335         iproc=itask_cont_from(ii)
7336         nn=ncont_recv(ii)
7337 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7338 c     &   " of CONT_TO_COMM group"
7339         call flush(iout)
7340         if (nn.gt.0) then
7341           ireq=ireq+1
7342           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7343      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7344 c          write (iout,*) "ireq,req",ireq,req(ireq)
7345         endif
7346       enddo
7347 C Send the contacts to processors that need them
7348       do ii=1,ntask_cont_to
7349         iproc=itask_cont_to(ii)
7350         nn=ncont_sent(ii)
7351 c        write (iout,*) nn," contacts to processor",iproc,
7352 c     &   " of CONT_TO_COMM group"
7353         if (nn.gt.0) then
7354           ireq=ireq+1
7355           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7356      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7357 c          write (iout,*) "ireq,req",ireq,req(ireq)
7358 c          do i=1,nn
7359 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7360 c          enddo
7361         endif
7362       enddo
7363 c      write (iout,*) "number of requests (contacts)",ireq
7364 c      write (iout,*) "req",(req(i),i=1,4)
7365 c      call flush(iout)
7366       if (ireq.gt.0)
7367      & call MPI_Waitall(ireq,req,status_array,ierr)
7368       do iii=1,ntask_cont_from
7369         iproc=itask_cont_from(iii)
7370         nn=ncont_recv(iii)
7371         if (lprn) then
7372         write (iout,*) "Received",nn," contacts from processor",iproc,
7373      &   " of CONT_FROM_COMM group"
7374         call flush(iout)
7375         do i=1,nn
7376           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7377         enddo
7378         call flush(iout)
7379         endif
7380         do i=1,nn
7381           ii=zapas_recv(1,i,iii)
7382 c Flag the received contacts to prevent double-counting
7383           jj=-zapas_recv(2,i,iii)
7384 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7385 c          call flush(iout)
7386           nnn=num_cont_hb(ii)+1
7387           num_cont_hb(ii)=nnn
7388           jcont_hb(nnn,ii)=jj
7389           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7390           ind=3
7391           do kk=1,3
7392             ind=ind+1
7393             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7394           enddo
7395           do kk=1,2
7396             do ll=1,2
7397               ind=ind+1
7398               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7399             enddo
7400           enddo
7401           do jj=1,5
7402             do kk=1,3
7403               do ll=1,2
7404                 do mm=1,2
7405                   ind=ind+1
7406                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7407                 enddo
7408               enddo
7409             enddo
7410           enddo
7411         enddo
7412       enddo
7413       call flush(iout)
7414       if (lprn) then
7415         write (iout,'(a)') 'Contact function values after receive:'
7416         do i=nnt,nct-2
7417           write (iout,'(2i3,50(1x,i3,5f6.3))')
7418      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7419      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7420         enddo
7421         call flush(iout)
7422       endif
7423    30 continue
7424 #endif
7425       if (lprn) then
7426         write (iout,'(a)') 'Contact function values:'
7427         do i=nnt,nct-2
7428           write (iout,'(2i3,50(1x,i2,5f6.3))')
7429      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7430      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7431         enddo
7432       endif
7433       ecorr=0.0D0
7434       ecorr5=0.0d0
7435       ecorr6=0.0d0
7436 C Remove the loop below after debugging !!!
7437       do i=nnt,nct
7438         do j=1,3
7439           gradcorr(j,i)=0.0D0
7440           gradxorr(j,i)=0.0D0
7441         enddo
7442       enddo
7443 C Calculate the dipole-dipole interaction energies
7444       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7445       do i=iatel_s,iatel_e+1
7446         num_conti=num_cont_hb(i)
7447         do jj=1,num_conti
7448           j=jcont_hb(jj,i)
7449 #ifdef MOMENT
7450           call dipole(i,j,jj)
7451 #endif
7452         enddo
7453       enddo
7454       endif
7455 C Calculate the local-electrostatic correlation terms
7456 c                write (iout,*) "gradcorr5 in eello5 before loop"
7457 c                do iii=1,nres
7458 c                  write (iout,'(i5,3f10.5)')
7459 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7460 c                enddo
7461       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7462 c        write (iout,*) "corr loop i",i
7463         i1=i+1
7464         num_conti=num_cont_hb(i)
7465         num_conti1=num_cont_hb(i+1)
7466         do jj=1,num_conti
7467           j=jcont_hb(jj,i)
7468           jp=iabs(j)
7469           do kk=1,num_conti1
7470             j1=jcont_hb(kk,i1)
7471             jp1=iabs(j1)
7472 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7473 c     &         ' jj=',jj,' kk=',kk
7474 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7475             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7476      &          .or. j.lt.0 .and. j1.gt.0) .and.
7477      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7478 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7479 C The system gains extra energy.
7480               n_corr=n_corr+1
7481               sqd1=dsqrt(d_cont(jj,i))
7482               sqd2=dsqrt(d_cont(kk,i1))
7483               sred_geom = sqd1*sqd2
7484               IF (sred_geom.lt.cutoff_corr) THEN
7485                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7486      &            ekont,fprimcont)
7487 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7488 cd     &         ' jj=',jj,' kk=',kk
7489                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7490                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7491                 do l=1,3
7492                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7493                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7494                 enddo
7495                 n_corr1=n_corr1+1
7496 cd               write (iout,*) 'sred_geom=',sred_geom,
7497 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7498 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7499 cd               write (iout,*) "g_contij",g_contij
7500 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7501 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7502                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7503                 if (wcorr4.gt.0.0d0)
7504      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7505                   if (energy_dec.and.wcorr4.gt.0.0d0)
7506      1                 write (iout,'(a6,4i5,0pf7.3)')
7507      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7508 c                write (iout,*) "gradcorr5 before eello5"
7509 c                do iii=1,nres
7510 c                  write (iout,'(i5,3f10.5)')
7511 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7512 c                enddo
7513                 if (wcorr5.gt.0.0d0)
7514      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7515 c                write (iout,*) "gradcorr5 after eello5"
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                   if (energy_dec.and.wcorr5.gt.0.0d0)
7521      1                 write (iout,'(a6,4i5,0pf7.3)')
7522      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7523 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7524 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7525                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7526      &               .or. wturn6.eq.0.0d0))then
7527 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7528                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7529                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7530      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7531 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7532 cd     &            'ecorr6=',ecorr6
7533 cd                write (iout,'(4e15.5)') sred_geom,
7534 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7535 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7536 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7537                 else if (wturn6.gt.0.0d0
7538      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7539 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7540                   eturn6=eturn6+eello_turn6(i,jj,kk)
7541                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7542      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7543 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7544                 endif
7545               ENDIF
7546 1111          continue
7547             endif
7548           enddo ! kk
7549         enddo ! jj
7550       enddo ! i
7551       do i=1,nres
7552         num_cont_hb(i)=num_cont_hb_old(i)
7553       enddo
7554 c                write (iout,*) "gradcorr5 in eello5"
7555 c                do iii=1,nres
7556 c                  write (iout,'(i5,3f10.5)')
7557 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7558 c                enddo
7559       return
7560       end
7561 c------------------------------------------------------------------------------
7562       subroutine add_hb_contact_eello(ii,jj,itask)
7563       implicit real*8 (a-h,o-z)
7564       include "DIMENSIONS"
7565       include "COMMON.IOUNITS"
7566       integer max_cont
7567       integer max_dim
7568       parameter (max_cont=maxconts)
7569       parameter (max_dim=70)
7570       include "COMMON.CONTACTS"
7571       double precision zapas(max_dim,maxconts,max_fg_procs),
7572      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7573       common /przechowalnia/ zapas
7574       integer i,j,ii,jj,iproc,itask(4),nn
7575 c      write (iout,*) "itask",itask
7576       do i=1,2
7577         iproc=itask(i)
7578         if (iproc.gt.0) then
7579           do j=1,num_cont_hb(ii)
7580             jjc=jcont_hb(j,ii)
7581 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7582             if (jjc.eq.jj) then
7583               ncont_sent(iproc)=ncont_sent(iproc)+1
7584               nn=ncont_sent(iproc)
7585               zapas(1,nn,iproc)=ii
7586               zapas(2,nn,iproc)=jjc
7587               zapas(3,nn,iproc)=d_cont(j,ii)
7588               ind=3
7589               do kk=1,3
7590                 ind=ind+1
7591                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7592               enddo
7593               do kk=1,2
7594                 do ll=1,2
7595                   ind=ind+1
7596                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7597                 enddo
7598               enddo
7599               do jj=1,5
7600                 do kk=1,3
7601                   do ll=1,2
7602                     do mm=1,2
7603                       ind=ind+1
7604                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7605                     enddo
7606                   enddo
7607                 enddo
7608               enddo
7609               exit
7610             endif
7611           enddo
7612         endif
7613       enddo
7614       return
7615       end
7616 c------------------------------------------------------------------------------
7617       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7618       implicit real*8 (a-h,o-z)
7619       include 'DIMENSIONS'
7620       include 'COMMON.IOUNITS'
7621       include 'COMMON.DERIV'
7622       include 'COMMON.INTERACT'
7623       include 'COMMON.CONTACTS'
7624       double precision gx(3),gx1(3)
7625       logical lprn
7626       lprn=.false.
7627       eij=facont_hb(jj,i)
7628       ekl=facont_hb(kk,k)
7629       ees0pij=ees0p(jj,i)
7630       ees0pkl=ees0p(kk,k)
7631       ees0mij=ees0m(jj,i)
7632       ees0mkl=ees0m(kk,k)
7633       ekont=eij*ekl
7634       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7635 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7636 C Following 4 lines for diagnostics.
7637 cd    ees0pkl=0.0D0
7638 cd    ees0pij=1.0D0
7639 cd    ees0mkl=0.0D0
7640 cd    ees0mij=1.0D0
7641 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7642 c     & 'Contacts ',i,j,
7643 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7644 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7645 c     & 'gradcorr_long'
7646 C Calculate the multi-body contribution to energy.
7647 c      ecorr=ecorr+ekont*ees
7648 C Calculate multi-body contributions to the gradient.
7649       coeffpees0pij=coeffp*ees0pij
7650       coeffmees0mij=coeffm*ees0mij
7651       coeffpees0pkl=coeffp*ees0pkl
7652       coeffmees0mkl=coeffm*ees0mkl
7653       do ll=1,3
7654 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7655         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7656      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7657      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7658         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7659      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7660      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7661 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7662         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7663      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7664      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7665         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7666      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7667      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7668         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7669      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7670      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7671         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7672         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7673         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7674      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7675      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7676         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7677         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7678 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7679       enddo
7680 c      write (iout,*)
7681 cgrad      do m=i+1,j-1
7682 cgrad        do ll=1,3
7683 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7684 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7685 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7686 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7687 cgrad        enddo
7688 cgrad      enddo
7689 cgrad      do m=k+1,l-1
7690 cgrad        do ll=1,3
7691 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7692 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7693 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7694 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7695 cgrad        enddo
7696 cgrad      enddo
7697 c      write (iout,*) "ehbcorr",ekont*ees
7698       ehbcorr=ekont*ees
7699       return
7700       end
7701 #ifdef MOMENT
7702 C---------------------------------------------------------------------------
7703       subroutine dipole(i,j,jj)
7704       implicit real*8 (a-h,o-z)
7705       include 'DIMENSIONS'
7706       include 'COMMON.IOUNITS'
7707       include 'COMMON.CHAIN'
7708       include 'COMMON.FFIELD'
7709       include 'COMMON.DERIV'
7710       include 'COMMON.INTERACT'
7711       include 'COMMON.CONTACTS'
7712       include 'COMMON.TORSION'
7713       include 'COMMON.VAR'
7714       include 'COMMON.GEO'
7715       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7716      &  auxmat(2,2)
7717       iti1 = itortyp(itype(i+1))
7718       if (j.lt.nres-1) then
7719         itj1 = itortyp(itype(j+1))
7720       else
7721         itj1=ntortyp+1
7722       endif
7723       do iii=1,2
7724         dipi(iii,1)=Ub2(iii,i)
7725         dipderi(iii)=Ub2der(iii,i)
7726         dipi(iii,2)=b1(iii,iti1)
7727         dipj(iii,1)=Ub2(iii,j)
7728         dipderj(iii)=Ub2der(iii,j)
7729         dipj(iii,2)=b1(iii,itj1)
7730       enddo
7731       kkk=0
7732       do iii=1,2
7733         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7734         do jjj=1,2
7735           kkk=kkk+1
7736           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7737         enddo
7738       enddo
7739       do kkk=1,5
7740         do lll=1,3
7741           mmm=0
7742           do iii=1,2
7743             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7744      &        auxvec(1))
7745             do jjj=1,2
7746               mmm=mmm+1
7747               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7748             enddo
7749           enddo
7750         enddo
7751       enddo
7752       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7753       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7754       do iii=1,2
7755         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7756       enddo
7757       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7758       do iii=1,2
7759         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7760       enddo
7761       return
7762       end
7763 #endif
7764 C---------------------------------------------------------------------------
7765       subroutine calc_eello(i,j,k,l,jj,kk)
7766 C
7767 C This subroutine computes matrices and vectors needed to calculate
7768 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7769 C
7770       implicit real*8 (a-h,o-z)
7771       include 'DIMENSIONS'
7772       include 'COMMON.IOUNITS'
7773       include 'COMMON.CHAIN'
7774       include 'COMMON.DERIV'
7775       include 'COMMON.INTERACT'
7776       include 'COMMON.CONTACTS'
7777       include 'COMMON.TORSION'
7778       include 'COMMON.VAR'
7779       include 'COMMON.GEO'
7780       include 'COMMON.FFIELD'
7781       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7782      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7783       logical lprn
7784       common /kutas/ lprn
7785 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7786 cd     & ' jj=',jj,' kk=',kk
7787 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7788 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7789 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7790       do iii=1,2
7791         do jjj=1,2
7792           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7793           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7794         enddo
7795       enddo
7796       call transpose2(aa1(1,1),aa1t(1,1))
7797       call transpose2(aa2(1,1),aa2t(1,1))
7798       do kkk=1,5
7799         do lll=1,3
7800           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7801      &      aa1tder(1,1,lll,kkk))
7802           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7803      &      aa2tder(1,1,lll,kkk))
7804         enddo
7805       enddo
7806       if (l.eq.j+1) then
7807 C parallel orientation of the two CA-CA-CA frames.
7808         if (i.gt.1) then
7809           iti=itortyp(itype(i))
7810         else
7811           iti=ntortyp+1
7812         endif
7813         itk1=itortyp(itype(k+1))
7814         itj=itortyp(itype(j))
7815         if (l.lt.nres-1) then
7816           itl1=itortyp(itype(l+1))
7817         else
7818           itl1=ntortyp+1
7819         endif
7820 C A1 kernel(j+1) A2T
7821 cd        do iii=1,2
7822 cd          write (iout,'(3f10.5,5x,3f10.5)')
7823 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7824 cd        enddo
7825         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7826      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7827      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7828 C Following matrices are needed only for 6-th order cumulants
7829         IF (wcorr6.gt.0.0d0) THEN
7830         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7831      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7832      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7833         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7834      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7835      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7836      &   ADtEAderx(1,1,1,1,1,1))
7837         lprn=.false.
7838         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7839      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7840      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7841      &   ADtEA1derx(1,1,1,1,1,1))
7842         ENDIF
7843 C End 6-th order cumulants
7844 cd        lprn=.false.
7845 cd        if (lprn) then
7846 cd        write (2,*) 'In calc_eello6'
7847 cd        do iii=1,2
7848 cd          write (2,*) 'iii=',iii
7849 cd          do kkk=1,5
7850 cd            write (2,*) 'kkk=',kkk
7851 cd            do jjj=1,2
7852 cd              write (2,'(3(2f10.5),5x)')
7853 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7854 cd            enddo
7855 cd          enddo
7856 cd        enddo
7857 cd        endif
7858         call transpose2(EUgder(1,1,k),auxmat(1,1))
7859         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7860         call transpose2(EUg(1,1,k),auxmat(1,1))
7861         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7862         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7863         do iii=1,2
7864           do kkk=1,5
7865             do lll=1,3
7866               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7867      &          EAEAderx(1,1,lll,kkk,iii,1))
7868             enddo
7869           enddo
7870         enddo
7871 C A1T kernel(i+1) A2
7872         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7873      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7874      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7875 C Following matrices are needed only for 6-th order cumulants
7876         IF (wcorr6.gt.0.0d0) THEN
7877         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7878      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7879      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7880         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7881      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7882      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7883      &   ADtEAderx(1,1,1,1,1,2))
7884         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7885      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7886      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7887      &   ADtEA1derx(1,1,1,1,1,2))
7888         ENDIF
7889 C End 6-th order cumulants
7890         call transpose2(EUgder(1,1,l),auxmat(1,1))
7891         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7892         call transpose2(EUg(1,1,l),auxmat(1,1))
7893         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7894         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7895         do iii=1,2
7896           do kkk=1,5
7897             do lll=1,3
7898               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7899      &          EAEAderx(1,1,lll,kkk,iii,2))
7900             enddo
7901           enddo
7902         enddo
7903 C AEAb1 and AEAb2
7904 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7905 C They are needed only when the fifth- or the sixth-order cumulants are
7906 C indluded.
7907         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7908         call transpose2(AEA(1,1,1),auxmat(1,1))
7909         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7910         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7911         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7912         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7913         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7914         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7915         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7916         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7917         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7918         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7919         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7920         call transpose2(AEA(1,1,2),auxmat(1,1))
7921         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7922         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7923         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7924         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7925         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7926         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7927         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7928         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7929         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7930         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7931         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7932 C Calculate the Cartesian derivatives of the vectors.
7933         do iii=1,2
7934           do kkk=1,5
7935             do lll=1,3
7936               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7937               call matvec2(auxmat(1,1),b1(1,iti),
7938      &          AEAb1derx(1,lll,kkk,iii,1,1))
7939               call matvec2(auxmat(1,1),Ub2(1,i),
7940      &          AEAb2derx(1,lll,kkk,iii,1,1))
7941               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7942      &          AEAb1derx(1,lll,kkk,iii,2,1))
7943               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7944      &          AEAb2derx(1,lll,kkk,iii,2,1))
7945               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7946               call matvec2(auxmat(1,1),b1(1,itj),
7947      &          AEAb1derx(1,lll,kkk,iii,1,2))
7948               call matvec2(auxmat(1,1),Ub2(1,j),
7949      &          AEAb2derx(1,lll,kkk,iii,1,2))
7950               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7951      &          AEAb1derx(1,lll,kkk,iii,2,2))
7952               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7953      &          AEAb2derx(1,lll,kkk,iii,2,2))
7954             enddo
7955           enddo
7956         enddo
7957         ENDIF
7958 C End vectors
7959       else
7960 C Antiparallel orientation of the two CA-CA-CA frames.
7961         if (i.gt.1) then
7962           iti=itortyp(itype(i))
7963         else
7964           iti=ntortyp+1
7965         endif
7966         itk1=itortyp(itype(k+1))
7967         itl=itortyp(itype(l))
7968         itj=itortyp(itype(j))
7969         if (j.lt.nres-1) then
7970           itj1=itortyp(itype(j+1))
7971         else
7972           itj1=ntortyp+1
7973         endif
7974 C A2 kernel(j-1)T A1T
7975         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7976      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7977      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7978 C Following matrices are needed only for 6-th order cumulants
7979         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7980      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7981         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7982      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7983      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7984         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7985      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7986      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7987      &   ADtEAderx(1,1,1,1,1,1))
7988         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7989      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7990      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7991      &   ADtEA1derx(1,1,1,1,1,1))
7992         ENDIF
7993 C End 6-th order cumulants
7994         call transpose2(EUgder(1,1,k),auxmat(1,1))
7995         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7996         call transpose2(EUg(1,1,k),auxmat(1,1))
7997         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7998         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7999         do iii=1,2
8000           do kkk=1,5
8001             do lll=1,3
8002               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8003      &          EAEAderx(1,1,lll,kkk,iii,1))
8004             enddo
8005           enddo
8006         enddo
8007 C A2T kernel(i+1)T A1
8008         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8009      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8010      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8011 C Following matrices are needed only for 6-th order cumulants
8012         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8013      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8014         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8015      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8016      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8017         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8018      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8019      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8020      &   ADtEAderx(1,1,1,1,1,2))
8021         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8022      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8023      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8024      &   ADtEA1derx(1,1,1,1,1,2))
8025         ENDIF
8026 C End 6-th order cumulants
8027         call transpose2(EUgder(1,1,j),auxmat(1,1))
8028         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8029         call transpose2(EUg(1,1,j),auxmat(1,1))
8030         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8031         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8032         do iii=1,2
8033           do kkk=1,5
8034             do lll=1,3
8035               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8036      &          EAEAderx(1,1,lll,kkk,iii,2))
8037             enddo
8038           enddo
8039         enddo
8040 C AEAb1 and AEAb2
8041 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8042 C They are needed only when the fifth- or the sixth-order cumulants are
8043 C indluded.
8044         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8045      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8046         call transpose2(AEA(1,1,1),auxmat(1,1))
8047         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8048         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8049         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8050         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8051         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8052         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8053         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8054         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8055         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8056         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8057         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8058         call transpose2(AEA(1,1,2),auxmat(1,1))
8059         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8060         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8061         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8062         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8063         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8064         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8065         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8066         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8067         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8068         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8069         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8070 C Calculate the Cartesian derivatives of the vectors.
8071         do iii=1,2
8072           do kkk=1,5
8073             do lll=1,3
8074               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8075               call matvec2(auxmat(1,1),b1(1,iti),
8076      &          AEAb1derx(1,lll,kkk,iii,1,1))
8077               call matvec2(auxmat(1,1),Ub2(1,i),
8078      &          AEAb2derx(1,lll,kkk,iii,1,1))
8079               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8080      &          AEAb1derx(1,lll,kkk,iii,2,1))
8081               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8082      &          AEAb2derx(1,lll,kkk,iii,2,1))
8083               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8084               call matvec2(auxmat(1,1),b1(1,itl),
8085      &          AEAb1derx(1,lll,kkk,iii,1,2))
8086               call matvec2(auxmat(1,1),Ub2(1,l),
8087      &          AEAb2derx(1,lll,kkk,iii,1,2))
8088               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
8089      &          AEAb1derx(1,lll,kkk,iii,2,2))
8090               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8091      &          AEAb2derx(1,lll,kkk,iii,2,2))
8092             enddo
8093           enddo
8094         enddo
8095         ENDIF
8096 C End vectors
8097       endif
8098       return
8099       end
8100 C---------------------------------------------------------------------------
8101       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8102      &  KK,KKderg,AKA,AKAderg,AKAderx)
8103       implicit none
8104       integer nderg
8105       logical transp
8106       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8107      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8108      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8109       integer iii,kkk,lll
8110       integer jjj,mmm
8111       logical lprn
8112       common /kutas/ lprn
8113       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8114       do iii=1,nderg
8115         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8116      &    AKAderg(1,1,iii))
8117       enddo
8118 cd      if (lprn) write (2,*) 'In kernel'
8119       do kkk=1,5
8120 cd        if (lprn) write (2,*) 'kkk=',kkk
8121         do lll=1,3
8122           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8123      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8124 cd          if (lprn) then
8125 cd            write (2,*) 'lll=',lll
8126 cd            write (2,*) 'iii=1'
8127 cd            do jjj=1,2
8128 cd              write (2,'(3(2f10.5),5x)')
8129 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8130 cd            enddo
8131 cd          endif
8132           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8133      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8134 cd          if (lprn) then
8135 cd            write (2,*) 'lll=',lll
8136 cd            write (2,*) 'iii=2'
8137 cd            do jjj=1,2
8138 cd              write (2,'(3(2f10.5),5x)')
8139 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8140 cd            enddo
8141 cd          endif
8142         enddo
8143       enddo
8144       return
8145       end
8146 C---------------------------------------------------------------------------
8147       double precision function eello4(i,j,k,l,jj,kk)
8148       implicit real*8 (a-h,o-z)
8149       include 'DIMENSIONS'
8150       include 'COMMON.IOUNITS'
8151       include 'COMMON.CHAIN'
8152       include 'COMMON.DERIV'
8153       include 'COMMON.INTERACT'
8154       include 'COMMON.CONTACTS'
8155       include 'COMMON.TORSION'
8156       include 'COMMON.VAR'
8157       include 'COMMON.GEO'
8158       double precision pizda(2,2),ggg1(3),ggg2(3)
8159 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8160 cd        eello4=0.0d0
8161 cd        return
8162 cd      endif
8163 cd      print *,'eello4:',i,j,k,l,jj,kk
8164 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8165 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8166 cold      eij=facont_hb(jj,i)
8167 cold      ekl=facont_hb(kk,k)
8168 cold      ekont=eij*ekl
8169       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8170 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8171       gcorr_loc(k-1)=gcorr_loc(k-1)
8172      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8173       if (l.eq.j+1) then
8174         gcorr_loc(l-1)=gcorr_loc(l-1)
8175      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8176       else
8177         gcorr_loc(j-1)=gcorr_loc(j-1)
8178      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8179       endif
8180       do iii=1,2
8181         do kkk=1,5
8182           do lll=1,3
8183             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8184      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8185 cd            derx(lll,kkk,iii)=0.0d0
8186           enddo
8187         enddo
8188       enddo
8189 cd      gcorr_loc(l-1)=0.0d0
8190 cd      gcorr_loc(j-1)=0.0d0
8191 cd      gcorr_loc(k-1)=0.0d0
8192 cd      eel4=1.0d0
8193 cd      write (iout,*)'Contacts have occurred for peptide groups',
8194 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8195 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8196       if (j.lt.nres-1) then
8197         j1=j+1
8198         j2=j-1
8199       else
8200         j1=j-1
8201         j2=j-2
8202       endif
8203       if (l.lt.nres-1) then
8204         l1=l+1
8205         l2=l-1
8206       else
8207         l1=l-1
8208         l2=l-2
8209       endif
8210       do ll=1,3
8211 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8212 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8213         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8214         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8215 cgrad        ghalf=0.5d0*ggg1(ll)
8216         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8217         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8218         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8219         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8220         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8221         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8222 cgrad        ghalf=0.5d0*ggg2(ll)
8223         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8224         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8225         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8226         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8227         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8228         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8229       enddo
8230 cgrad      do m=i+1,j-1
8231 cgrad        do ll=1,3
8232 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8233 cgrad        enddo
8234 cgrad      enddo
8235 cgrad      do m=k+1,l-1
8236 cgrad        do ll=1,3
8237 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8238 cgrad        enddo
8239 cgrad      enddo
8240 cgrad      do m=i+2,j2
8241 cgrad        do ll=1,3
8242 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8243 cgrad        enddo
8244 cgrad      enddo
8245 cgrad      do m=k+2,l2
8246 cgrad        do ll=1,3
8247 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8248 cgrad        enddo
8249 cgrad      enddo
8250 cd      do iii=1,nres-3
8251 cd        write (2,*) iii,gcorr_loc(iii)
8252 cd      enddo
8253       eello4=ekont*eel4
8254 cd      write (2,*) 'ekont',ekont
8255 cd      write (iout,*) 'eello4',ekont*eel4
8256       return
8257       end
8258 C---------------------------------------------------------------------------
8259       double precision function eello5(i,j,k,l,jj,kk)
8260       implicit real*8 (a-h,o-z)
8261       include 'DIMENSIONS'
8262       include 'COMMON.IOUNITS'
8263       include 'COMMON.CHAIN'
8264       include 'COMMON.DERIV'
8265       include 'COMMON.INTERACT'
8266       include 'COMMON.CONTACTS'
8267       include 'COMMON.TORSION'
8268       include 'COMMON.VAR'
8269       include 'COMMON.GEO'
8270       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8271       double precision ggg1(3),ggg2(3)
8272 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8273 C                                                                              C
8274 C                            Parallel chains                                   C
8275 C                                                                              C
8276 C          o             o                   o             o                   C
8277 C         /l\           / \             \   / \           / \   /              C
8278 C        /   \         /   \             \ /   \         /   \ /               C
8279 C       j| o |l1       | o |              o| o |         | o |o                C
8280 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8281 C      \i/   \         /   \ /             /   \         /   \                 C
8282 C       o    k1             o                                                  C
8283 C         (I)          (II)                (III)          (IV)                 C
8284 C                                                                              C
8285 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8286 C                                                                              C
8287 C                            Antiparallel chains                               C
8288 C                                                                              C
8289 C          o             o                   o             o                   C
8290 C         /j\           / \             \   / \           / \   /              C
8291 C        /   \         /   \             \ /   \         /   \ /               C
8292 C      j1| o |l        | o |              o| o |         | o |o                C
8293 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8294 C      \i/   \         /   \ /             /   \         /   \                 C
8295 C       o     k1            o                                                  C
8296 C         (I)          (II)                (III)          (IV)                 C
8297 C                                                                              C
8298 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8299 C                                                                              C
8300 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8301 C                                                                              C
8302 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8303 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8304 cd        eello5=0.0d0
8305 cd        return
8306 cd      endif
8307 cd      write (iout,*)
8308 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8309 cd     &   ' and',k,l
8310       itk=itortyp(itype(k))
8311       itl=itortyp(itype(l))
8312       itj=itortyp(itype(j))
8313       eello5_1=0.0d0
8314       eello5_2=0.0d0
8315       eello5_3=0.0d0
8316       eello5_4=0.0d0
8317 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8318 cd     &   eel5_3_num,eel5_4_num)
8319       do iii=1,2
8320         do kkk=1,5
8321           do lll=1,3
8322             derx(lll,kkk,iii)=0.0d0
8323           enddo
8324         enddo
8325       enddo
8326 cd      eij=facont_hb(jj,i)
8327 cd      ekl=facont_hb(kk,k)
8328 cd      ekont=eij*ekl
8329 cd      write (iout,*)'Contacts have occurred for peptide groups',
8330 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8331 cd      goto 1111
8332 C Contribution from the graph I.
8333 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8334 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8335       call transpose2(EUg(1,1,k),auxmat(1,1))
8336       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8337       vv(1)=pizda(1,1)-pizda(2,2)
8338       vv(2)=pizda(1,2)+pizda(2,1)
8339       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8340      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8341 C Explicit gradient in virtual-dihedral angles.
8342       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8343      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8344      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8345       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8346       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8347       vv(1)=pizda(1,1)-pizda(2,2)
8348       vv(2)=pizda(1,2)+pizda(2,1)
8349       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8350      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8351      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8352       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8353       vv(1)=pizda(1,1)-pizda(2,2)
8354       vv(2)=pizda(1,2)+pizda(2,1)
8355       if (l.eq.j+1) then
8356         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8357      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8358      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8359       else
8360         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8361      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8362      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8363       endif
8364 C Cartesian gradient
8365       do iii=1,2
8366         do kkk=1,5
8367           do lll=1,3
8368             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8369      &        pizda(1,1))
8370             vv(1)=pizda(1,1)-pizda(2,2)
8371             vv(2)=pizda(1,2)+pizda(2,1)
8372             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8373      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8374      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8375           enddo
8376         enddo
8377       enddo
8378 c      goto 1112
8379 c1111  continue
8380 C Contribution from graph II
8381       call transpose2(EE(1,1,itk),auxmat(1,1))
8382       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8383       vv(1)=pizda(1,1)+pizda(2,2)
8384       vv(2)=pizda(2,1)-pizda(1,2)
8385       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8386      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8387 C Explicit gradient in virtual-dihedral angles.
8388       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8389      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8390       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8391       vv(1)=pizda(1,1)+pizda(2,2)
8392       vv(2)=pizda(2,1)-pizda(1,2)
8393       if (l.eq.j+1) then
8394         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8395      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8396      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8397       else
8398         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8399      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8400      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8401       endif
8402 C Cartesian gradient
8403       do iii=1,2
8404         do kkk=1,5
8405           do lll=1,3
8406             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8407      &        pizda(1,1))
8408             vv(1)=pizda(1,1)+pizda(2,2)
8409             vv(2)=pizda(2,1)-pizda(1,2)
8410             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8411      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8412      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8413           enddo
8414         enddo
8415       enddo
8416 cd      goto 1112
8417 cd1111  continue
8418       if (l.eq.j+1) then
8419 cd        goto 1110
8420 C Parallel orientation
8421 C Contribution from graph III
8422         call transpose2(EUg(1,1,l),auxmat(1,1))
8423         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8424         vv(1)=pizda(1,1)-pizda(2,2)
8425         vv(2)=pizda(1,2)+pizda(2,1)
8426         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8427      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8428 C Explicit gradient in virtual-dihedral angles.
8429         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8430      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8431      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8432         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8433         vv(1)=pizda(1,1)-pizda(2,2)
8434         vv(2)=pizda(1,2)+pizda(2,1)
8435         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8436      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8437      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8438         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8439         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8440         vv(1)=pizda(1,1)-pizda(2,2)
8441         vv(2)=pizda(1,2)+pizda(2,1)
8442         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8443      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8444      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8445 C Cartesian gradient
8446         do iii=1,2
8447           do kkk=1,5
8448             do lll=1,3
8449               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8450      &          pizda(1,1))
8451               vv(1)=pizda(1,1)-pizda(2,2)
8452               vv(2)=pizda(1,2)+pizda(2,1)
8453               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8454      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8455      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8456             enddo
8457           enddo
8458         enddo
8459 cd        goto 1112
8460 C Contribution from graph IV
8461 cd1110    continue
8462         call transpose2(EE(1,1,itl),auxmat(1,1))
8463         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8464         vv(1)=pizda(1,1)+pizda(2,2)
8465         vv(2)=pizda(2,1)-pizda(1,2)
8466         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8467      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8468 C Explicit gradient in virtual-dihedral angles.
8469         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8470      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8471         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8472         vv(1)=pizda(1,1)+pizda(2,2)
8473         vv(2)=pizda(2,1)-pizda(1,2)
8474         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8475      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8476      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8477 C Cartesian gradient
8478         do iii=1,2
8479           do kkk=1,5
8480             do lll=1,3
8481               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8482      &          pizda(1,1))
8483               vv(1)=pizda(1,1)+pizda(2,2)
8484               vv(2)=pizda(2,1)-pizda(1,2)
8485               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8486      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8487      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8488             enddo
8489           enddo
8490         enddo
8491       else
8492 C Antiparallel orientation
8493 C Contribution from graph III
8494 c        goto 1110
8495         call transpose2(EUg(1,1,j),auxmat(1,1))
8496         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8497         vv(1)=pizda(1,1)-pizda(2,2)
8498         vv(2)=pizda(1,2)+pizda(2,1)
8499         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8500      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8501 C Explicit gradient in virtual-dihedral angles.
8502         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8503      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8504      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8505         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8506         vv(1)=pizda(1,1)-pizda(2,2)
8507         vv(2)=pizda(1,2)+pizda(2,1)
8508         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8509      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8510      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8511         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8512         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8513         vv(1)=pizda(1,1)-pizda(2,2)
8514         vv(2)=pizda(1,2)+pizda(2,1)
8515         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8516      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8517      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8518 C Cartesian gradient
8519         do iii=1,2
8520           do kkk=1,5
8521             do lll=1,3
8522               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8523      &          pizda(1,1))
8524               vv(1)=pizda(1,1)-pizda(2,2)
8525               vv(2)=pizda(1,2)+pizda(2,1)
8526               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8527      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8528      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8529             enddo
8530           enddo
8531         enddo
8532 cd        goto 1112
8533 C Contribution from graph IV
8534 1110    continue
8535         call transpose2(EE(1,1,itj),auxmat(1,1))
8536         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8537         vv(1)=pizda(1,1)+pizda(2,2)
8538         vv(2)=pizda(2,1)-pizda(1,2)
8539         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8540      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8541 C Explicit gradient in virtual-dihedral angles.
8542         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8543      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8544         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8545         vv(1)=pizda(1,1)+pizda(2,2)
8546         vv(2)=pizda(2,1)-pizda(1,2)
8547         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8548      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8549      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8550 C Cartesian gradient
8551         do iii=1,2
8552           do kkk=1,5
8553             do lll=1,3
8554               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8555      &          pizda(1,1))
8556               vv(1)=pizda(1,1)+pizda(2,2)
8557               vv(2)=pizda(2,1)-pizda(1,2)
8558               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8559      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8560      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8561             enddo
8562           enddo
8563         enddo
8564       endif
8565 1112  continue
8566       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8567 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8568 cd        write (2,*) 'ijkl',i,j,k,l
8569 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8570 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8571 cd      endif
8572 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8573 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8574 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8575 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8576       if (j.lt.nres-1) then
8577         j1=j+1
8578         j2=j-1
8579       else
8580         j1=j-1
8581         j2=j-2
8582       endif
8583       if (l.lt.nres-1) then
8584         l1=l+1
8585         l2=l-1
8586       else
8587         l1=l-1
8588         l2=l-2
8589       endif
8590 cd      eij=1.0d0
8591 cd      ekl=1.0d0
8592 cd      ekont=1.0d0
8593 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8594 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8595 C        summed up outside the subrouine as for the other subroutines
8596 C        handling long-range interactions. The old code is commented out
8597 C        with "cgrad" to keep track of changes.
8598       do ll=1,3
8599 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8600 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8601         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8602         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8603 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8604 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8605 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8606 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8607 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8608 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8609 c     &   gradcorr5ij,
8610 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8611 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8612 cgrad        ghalf=0.5d0*ggg1(ll)
8613 cd        ghalf=0.0d0
8614         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8615         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8616         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8617         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8618         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8619         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8620 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8621 cgrad        ghalf=0.5d0*ggg2(ll)
8622 cd        ghalf=0.0d0
8623         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8624         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8625         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8626         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8627         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8628         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8629       enddo
8630 cd      goto 1112
8631 cgrad      do m=i+1,j-1
8632 cgrad        do ll=1,3
8633 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8634 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8635 cgrad        enddo
8636 cgrad      enddo
8637 cgrad      do m=k+1,l-1
8638 cgrad        do ll=1,3
8639 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8640 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8641 cgrad        enddo
8642 cgrad      enddo
8643 c1112  continue
8644 cgrad      do m=i+2,j2
8645 cgrad        do ll=1,3
8646 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8647 cgrad        enddo
8648 cgrad      enddo
8649 cgrad      do m=k+2,l2
8650 cgrad        do ll=1,3
8651 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8652 cgrad        enddo
8653 cgrad      enddo
8654 cd      do iii=1,nres-3
8655 cd        write (2,*) iii,g_corr5_loc(iii)
8656 cd      enddo
8657       eello5=ekont*eel5
8658 cd      write (2,*) 'ekont',ekont
8659 cd      write (iout,*) 'eello5',ekont*eel5
8660       return
8661       end
8662 c--------------------------------------------------------------------------
8663       double precision function eello6(i,j,k,l,jj,kk)
8664       implicit real*8 (a-h,o-z)
8665       include 'DIMENSIONS'
8666       include 'COMMON.IOUNITS'
8667       include 'COMMON.CHAIN'
8668       include 'COMMON.DERIV'
8669       include 'COMMON.INTERACT'
8670       include 'COMMON.CONTACTS'
8671       include 'COMMON.TORSION'
8672       include 'COMMON.VAR'
8673       include 'COMMON.GEO'
8674       include 'COMMON.FFIELD'
8675       double precision ggg1(3),ggg2(3)
8676 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8677 cd        eello6=0.0d0
8678 cd        return
8679 cd      endif
8680 cd      write (iout,*)
8681 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8682 cd     &   ' and',k,l
8683       eello6_1=0.0d0
8684       eello6_2=0.0d0
8685       eello6_3=0.0d0
8686       eello6_4=0.0d0
8687       eello6_5=0.0d0
8688       eello6_6=0.0d0
8689 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8690 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8691       do iii=1,2
8692         do kkk=1,5
8693           do lll=1,3
8694             derx(lll,kkk,iii)=0.0d0
8695           enddo
8696         enddo
8697       enddo
8698 cd      eij=facont_hb(jj,i)
8699 cd      ekl=facont_hb(kk,k)
8700 cd      ekont=eij*ekl
8701 cd      eij=1.0d0
8702 cd      ekl=1.0d0
8703 cd      ekont=1.0d0
8704       if (l.eq.j+1) then
8705         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8706         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8707         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8708         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8709         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8710         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8711       else
8712         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8713         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8714         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8715         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8716         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8717           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8718         else
8719           eello6_5=0.0d0
8720         endif
8721         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8722       endif
8723 C If turn contributions are considered, they will be handled separately.
8724       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8725 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8726 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8727 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8728 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8729 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8730 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8731 cd      goto 1112
8732       if (j.lt.nres-1) then
8733         j1=j+1
8734         j2=j-1
8735       else
8736         j1=j-1
8737         j2=j-2
8738       endif
8739       if (l.lt.nres-1) then
8740         l1=l+1
8741         l2=l-1
8742       else
8743         l1=l-1
8744         l2=l-2
8745       endif
8746       do ll=1,3
8747 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8748 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8749 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8750 cgrad        ghalf=0.5d0*ggg1(ll)
8751 cd        ghalf=0.0d0
8752         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8753         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8754         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8755         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8756         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8757         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8758         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8759         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8760 cgrad        ghalf=0.5d0*ggg2(ll)
8761 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8762 cd        ghalf=0.0d0
8763         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8764         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8765         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8766         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8767         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8768         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8769       enddo
8770 cd      goto 1112
8771 cgrad      do m=i+1,j-1
8772 cgrad        do ll=1,3
8773 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8774 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8775 cgrad        enddo
8776 cgrad      enddo
8777 cgrad      do m=k+1,l-1
8778 cgrad        do ll=1,3
8779 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8780 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8781 cgrad        enddo
8782 cgrad      enddo
8783 cgrad1112  continue
8784 cgrad      do m=i+2,j2
8785 cgrad        do ll=1,3
8786 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8787 cgrad        enddo
8788 cgrad      enddo
8789 cgrad      do m=k+2,l2
8790 cgrad        do ll=1,3
8791 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8792 cgrad        enddo
8793 cgrad      enddo
8794 cd      do iii=1,nres-3
8795 cd        write (2,*) iii,g_corr6_loc(iii)
8796 cd      enddo
8797       eello6=ekont*eel6
8798 cd      write (2,*) 'ekont',ekont
8799 cd      write (iout,*) 'eello6',ekont*eel6
8800       return
8801       end
8802 c--------------------------------------------------------------------------
8803       double precision function eello6_graph1(i,j,k,l,imat,swap)
8804       implicit real*8 (a-h,o-z)
8805       include 'DIMENSIONS'
8806       include 'COMMON.IOUNITS'
8807       include 'COMMON.CHAIN'
8808       include 'COMMON.DERIV'
8809       include 'COMMON.INTERACT'
8810       include 'COMMON.CONTACTS'
8811       include 'COMMON.TORSION'
8812       include 'COMMON.VAR'
8813       include 'COMMON.GEO'
8814       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8815       logical swap
8816       logical lprn
8817       common /kutas/ lprn
8818 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8819 C
8820 C      Parallel       Antiparallel
8821 C
8822 C          o             o
8823 C         /l\           /j\
8824 C        /   \         /   \
8825 C       /| o |         | o |\
8826 C     \ j|/k\|  /   \  |/k\|l /
8827 C      \ /   \ /     \ /   \ /
8828 C       o     o       o     o
8829 C       i             i
8830 C
8831 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8832       itk=itortyp(itype(k))
8833       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8834       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8835       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8836       call transpose2(EUgC(1,1,k),auxmat(1,1))
8837       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8838       vv1(1)=pizda1(1,1)-pizda1(2,2)
8839       vv1(2)=pizda1(1,2)+pizda1(2,1)
8840       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8841       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8842       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8843       s5=scalar2(vv(1),Dtobr2(1,i))
8844 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8845       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8846       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8847      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8848      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8849      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8850      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8851      & +scalar2(vv(1),Dtobr2der(1,i)))
8852       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8853       vv1(1)=pizda1(1,1)-pizda1(2,2)
8854       vv1(2)=pizda1(1,2)+pizda1(2,1)
8855       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8856       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8857       if (l.eq.j+1) then
8858         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8859      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8860      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8861      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8862      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8863       else
8864         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8865      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8866      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8867      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8868      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8869       endif
8870       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8871       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8872       vv1(1)=pizda1(1,1)-pizda1(2,2)
8873       vv1(2)=pizda1(1,2)+pizda1(2,1)
8874       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8875      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8876      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8877      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8878       do iii=1,2
8879         if (swap) then
8880           ind=3-iii
8881         else
8882           ind=iii
8883         endif
8884         do kkk=1,5
8885           do lll=1,3
8886             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8887             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8888             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8889             call transpose2(EUgC(1,1,k),auxmat(1,1))
8890             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8891      &        pizda1(1,1))
8892             vv1(1)=pizda1(1,1)-pizda1(2,2)
8893             vv1(2)=pizda1(1,2)+pizda1(2,1)
8894             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8895             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8896      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8897             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8898      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8899             s5=scalar2(vv(1),Dtobr2(1,i))
8900             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8901           enddo
8902         enddo
8903       enddo
8904       return
8905       end
8906 c----------------------------------------------------------------------------
8907       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8908       implicit real*8 (a-h,o-z)
8909       include 'DIMENSIONS'
8910       include 'COMMON.IOUNITS'
8911       include 'COMMON.CHAIN'
8912       include 'COMMON.DERIV'
8913       include 'COMMON.INTERACT'
8914       include 'COMMON.CONTACTS'
8915       include 'COMMON.TORSION'
8916       include 'COMMON.VAR'
8917       include 'COMMON.GEO'
8918       logical swap
8919       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8920      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8921       logical lprn
8922       common /kutas/ lprn
8923 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8924 C                                                                              C
8925 C      Parallel       Antiparallel                                             C
8926 C                                                                              C
8927 C          o             o                                                     C
8928 C     \   /l\           /j\   /                                                C
8929 C      \ /   \         /   \ /                                                 C
8930 C       o| o |         | o |o                                                  C
8931 C     \ j|/k\|      \  |/k\|l                                                  C
8932 C      \ /   \       \ /   \                                                   C
8933 C       o             o                                                        C
8934 C       i             i                                                        C
8935 C                                                                              C
8936 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8937 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8938 C AL 7/4/01 s1 would occur in the sixth-order moment,
8939 C           but not in a cluster cumulant
8940 #ifdef MOMENT
8941       s1=dip(1,jj,i)*dip(1,kk,k)
8942 #endif
8943       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8944       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8945       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8946       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8947       call transpose2(EUg(1,1,k),auxmat(1,1))
8948       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8949       vv(1)=pizda(1,1)-pizda(2,2)
8950       vv(2)=pizda(1,2)+pizda(2,1)
8951       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8952 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8953 #ifdef MOMENT
8954       eello6_graph2=-(s1+s2+s3+s4)
8955 #else
8956       eello6_graph2=-(s2+s3+s4)
8957 #endif
8958 c      eello6_graph2=-s3
8959 C Derivatives in gamma(i-1)
8960       if (i.gt.1) then
8961 #ifdef MOMENT
8962         s1=dipderg(1,jj,i)*dip(1,kk,k)
8963 #endif
8964         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8965         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8966         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8967         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8968 #ifdef MOMENT
8969         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8970 #else
8971         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8972 #endif
8973 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8974       endif
8975 C Derivatives in gamma(k-1)
8976 #ifdef MOMENT
8977       s1=dip(1,jj,i)*dipderg(1,kk,k)
8978 #endif
8979       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8980       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8981       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8982       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8983       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8984       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8985       vv(1)=pizda(1,1)-pizda(2,2)
8986       vv(2)=pizda(1,2)+pizda(2,1)
8987       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8988 #ifdef MOMENT
8989       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8990 #else
8991       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8992 #endif
8993 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8994 C Derivatives in gamma(j-1) or gamma(l-1)
8995       if (j.gt.1) then
8996 #ifdef MOMENT
8997         s1=dipderg(3,jj,i)*dip(1,kk,k)
8998 #endif
8999         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9000         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9001         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9002         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9003         vv(1)=pizda(1,1)-pizda(2,2)
9004         vv(2)=pizda(1,2)+pizda(2,1)
9005         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9006 #ifdef MOMENT
9007         if (swap) then
9008           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9009         else
9010           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9011         endif
9012 #endif
9013         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9014 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9015       endif
9016 C Derivatives in gamma(l-1) or gamma(j-1)
9017       if (l.gt.1) then
9018 #ifdef MOMENT
9019         s1=dip(1,jj,i)*dipderg(3,kk,k)
9020 #endif
9021         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9022         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9023         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9024         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9025         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9026         vv(1)=pizda(1,1)-pizda(2,2)
9027         vv(2)=pizda(1,2)+pizda(2,1)
9028         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9029 #ifdef MOMENT
9030         if (swap) then
9031           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9032         else
9033           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9034         endif
9035 #endif
9036         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9037 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9038       endif
9039 C Cartesian derivatives.
9040       if (lprn) then
9041         write (2,*) 'In eello6_graph2'
9042         do iii=1,2
9043           write (2,*) 'iii=',iii
9044           do kkk=1,5
9045             write (2,*) 'kkk=',kkk
9046             do jjj=1,2
9047               write (2,'(3(2f10.5),5x)')
9048      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9049             enddo
9050           enddo
9051         enddo
9052       endif
9053       do iii=1,2
9054         do kkk=1,5
9055           do lll=1,3
9056 #ifdef MOMENT
9057             if (iii.eq.1) then
9058               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9059             else
9060               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9061             endif
9062 #endif
9063             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9064      &        auxvec(1))
9065             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9066             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9067      &        auxvec(1))
9068             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9069             call transpose2(EUg(1,1,k),auxmat(1,1))
9070             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9071      &        pizda(1,1))
9072             vv(1)=pizda(1,1)-pizda(2,2)
9073             vv(2)=pizda(1,2)+pizda(2,1)
9074             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9075 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9076 #ifdef MOMENT
9077             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9078 #else
9079             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9080 #endif
9081             if (swap) then
9082               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9083             else
9084               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9085             endif
9086           enddo
9087         enddo
9088       enddo
9089       return
9090       end
9091 c----------------------------------------------------------------------------
9092       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9093       implicit real*8 (a-h,o-z)
9094       include 'DIMENSIONS'
9095       include 'COMMON.IOUNITS'
9096       include 'COMMON.CHAIN'
9097       include 'COMMON.DERIV'
9098       include 'COMMON.INTERACT'
9099       include 'COMMON.CONTACTS'
9100       include 'COMMON.TORSION'
9101       include 'COMMON.VAR'
9102       include 'COMMON.GEO'
9103       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9104       logical swap
9105 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9106 C                                                                              C
9107 C      Parallel       Antiparallel                                             C
9108 C                                                                              C
9109 C          o             o                                                     C
9110 C         /l\   /   \   /j\                                                    C
9111 C        /   \ /     \ /   \                                                   C
9112 C       /| o |o       o| o |\                                                  C
9113 C       j|/k\|  /      |/k\|l /                                                C
9114 C        /   \ /       /   \ /                                                 C
9115 C       /     o       /     o                                                  C
9116 C       i             i                                                        C
9117 C                                                                              C
9118 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9119 C
9120 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9121 C           energy moment and not to the cluster cumulant.
9122       iti=itortyp(itype(i))
9123       if (j.lt.nres-1) then
9124         itj1=itortyp(itype(j+1))
9125       else
9126         itj1=ntortyp+1
9127       endif
9128       itk=itortyp(itype(k))
9129       itk1=itortyp(itype(k+1))
9130       if (l.lt.nres-1) then
9131         itl1=itortyp(itype(l+1))
9132       else
9133         itl1=ntortyp+1
9134       endif
9135 #ifdef MOMENT
9136       s1=dip(4,jj,i)*dip(4,kk,k)
9137 #endif
9138       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9139       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9140       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9141       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9142       call transpose2(EE(1,1,itk),auxmat(1,1))
9143       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9144       vv(1)=pizda(1,1)+pizda(2,2)
9145       vv(2)=pizda(2,1)-pizda(1,2)
9146       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9147 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9148 cd     & "sum",-(s2+s3+s4)
9149 #ifdef MOMENT
9150       eello6_graph3=-(s1+s2+s3+s4)
9151 #else
9152       eello6_graph3=-(s2+s3+s4)
9153 #endif
9154 c      eello6_graph3=-s4
9155 C Derivatives in gamma(k-1)
9156       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9157       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9158       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9159       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9160 C Derivatives in gamma(l-1)
9161       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9162       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9163       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9164       vv(1)=pizda(1,1)+pizda(2,2)
9165       vv(2)=pizda(2,1)-pizda(1,2)
9166       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9167       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9168 C Cartesian derivatives.
9169       do iii=1,2
9170         do kkk=1,5
9171           do lll=1,3
9172 #ifdef MOMENT
9173             if (iii.eq.1) then
9174               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9175             else
9176               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9177             endif
9178 #endif
9179             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
9180      &        auxvec(1))
9181             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9182             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
9183      &        auxvec(1))
9184             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9185             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9186      &        pizda(1,1))
9187             vv(1)=pizda(1,1)+pizda(2,2)
9188             vv(2)=pizda(2,1)-pizda(1,2)
9189             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9190 #ifdef MOMENT
9191             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9192 #else
9193             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9194 #endif
9195             if (swap) then
9196               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9197             else
9198               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9199             endif
9200 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9201           enddo
9202         enddo
9203       enddo
9204       return
9205       end
9206 c----------------------------------------------------------------------------
9207       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9208       implicit real*8 (a-h,o-z)
9209       include 'DIMENSIONS'
9210       include 'COMMON.IOUNITS'
9211       include 'COMMON.CHAIN'
9212       include 'COMMON.DERIV'
9213       include 'COMMON.INTERACT'
9214       include 'COMMON.CONTACTS'
9215       include 'COMMON.TORSION'
9216       include 'COMMON.VAR'
9217       include 'COMMON.GEO'
9218       include 'COMMON.FFIELD'
9219       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9220      & auxvec1(2),auxmat1(2,2)
9221       logical swap
9222 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9223 C                                                                              C
9224 C      Parallel       Antiparallel                                             C
9225 C                                                                              C
9226 C          o             o                                                     C
9227 C         /l\   /   \   /j\                                                    C
9228 C        /   \ /     \ /   \                                                   C
9229 C       /| o |o       o| o |\                                                  C
9230 C     \ j|/k\|      \  |/k\|l                                                  C
9231 C      \ /   \       \ /   \                                                   C
9232 C       o     \       o     \                                                  C
9233 C       i             i                                                        C
9234 C                                                                              C
9235 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9236 C
9237 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9238 C           energy moment and not to the cluster cumulant.
9239 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9240       iti=itortyp(itype(i))
9241       itj=itortyp(itype(j))
9242       if (j.lt.nres-1) then
9243         itj1=itortyp(itype(j+1))
9244       else
9245         itj1=ntortyp+1
9246       endif
9247       itk=itortyp(itype(k))
9248       if (k.lt.nres-1) then
9249         itk1=itortyp(itype(k+1))
9250       else
9251         itk1=ntortyp+1
9252       endif
9253       itl=itortyp(itype(l))
9254       if (l.lt.nres-1) then
9255         itl1=itortyp(itype(l+1))
9256       else
9257         itl1=ntortyp+1
9258       endif
9259 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9260 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9261 cd     & ' itl',itl,' itl1',itl1
9262 #ifdef MOMENT
9263       if (imat.eq.1) then
9264         s1=dip(3,jj,i)*dip(3,kk,k)
9265       else
9266         s1=dip(2,jj,j)*dip(2,kk,l)
9267       endif
9268 #endif
9269       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9270       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9271       if (j.eq.l+1) then
9272         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9273         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9274       else
9275         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9276         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9277       endif
9278       call transpose2(EUg(1,1,k),auxmat(1,1))
9279       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9280       vv(1)=pizda(1,1)-pizda(2,2)
9281       vv(2)=pizda(2,1)+pizda(1,2)
9282       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9283 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9284 #ifdef MOMENT
9285       eello6_graph4=-(s1+s2+s3+s4)
9286 #else
9287       eello6_graph4=-(s2+s3+s4)
9288 #endif
9289 C Derivatives in gamma(i-1)
9290       if (i.gt.1) then
9291 #ifdef MOMENT
9292         if (imat.eq.1) then
9293           s1=dipderg(2,jj,i)*dip(3,kk,k)
9294         else
9295           s1=dipderg(4,jj,j)*dip(2,kk,l)
9296         endif
9297 #endif
9298         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9299         if (j.eq.l+1) then
9300           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9301           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9302         else
9303           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9304           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9305         endif
9306         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9307         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9308 cd          write (2,*) 'turn6 derivatives'
9309 #ifdef MOMENT
9310           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9311 #else
9312           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9313 #endif
9314         else
9315 #ifdef MOMENT
9316           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9317 #else
9318           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9319 #endif
9320         endif
9321       endif
9322 C Derivatives in gamma(k-1)
9323 #ifdef MOMENT
9324       if (imat.eq.1) then
9325         s1=dip(3,jj,i)*dipderg(2,kk,k)
9326       else
9327         s1=dip(2,jj,j)*dipderg(4,kk,l)
9328       endif
9329 #endif
9330       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9331       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9332       if (j.eq.l+1) then
9333         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9334         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9335       else
9336         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9337         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9338       endif
9339       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9340       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9341       vv(1)=pizda(1,1)-pizda(2,2)
9342       vv(2)=pizda(2,1)+pizda(1,2)
9343       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9344       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9345 #ifdef MOMENT
9346         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9347 #else
9348         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9349 #endif
9350       else
9351 #ifdef MOMENT
9352         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9353 #else
9354         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9355 #endif
9356       endif
9357 C Derivatives in gamma(j-1) or gamma(l-1)
9358       if (l.eq.j+1 .and. l.gt.1) then
9359         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9360         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9361         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9362         vv(1)=pizda(1,1)-pizda(2,2)
9363         vv(2)=pizda(2,1)+pizda(1,2)
9364         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9365         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9366       else if (j.gt.1) then
9367         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9368         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9369         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9370         vv(1)=pizda(1,1)-pizda(2,2)
9371         vv(2)=pizda(2,1)+pizda(1,2)
9372         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9373         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9374           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9375         else
9376           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9377         endif
9378       endif
9379 C Cartesian derivatives.
9380       do iii=1,2
9381         do kkk=1,5
9382           do lll=1,3
9383 #ifdef MOMENT
9384             if (iii.eq.1) then
9385               if (imat.eq.1) then
9386                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9387               else
9388                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9389               endif
9390             else
9391               if (imat.eq.1) then
9392                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9393               else
9394                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9395               endif
9396             endif
9397 #endif
9398             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9399      &        auxvec(1))
9400             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9401             if (j.eq.l+1) then
9402               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9403      &          b1(1,itj1),auxvec(1))
9404               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9405             else
9406               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9407      &          b1(1,itl1),auxvec(1))
9408               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9409             endif
9410             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9411      &        pizda(1,1))
9412             vv(1)=pizda(1,1)-pizda(2,2)
9413             vv(2)=pizda(2,1)+pizda(1,2)
9414             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9415             if (swap) then
9416               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9417 #ifdef MOMENT
9418                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9419      &             -(s1+s2+s4)
9420 #else
9421                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9422      &             -(s2+s4)
9423 #endif
9424                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9425               else
9426 #ifdef MOMENT
9427                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9428 #else
9429                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9430 #endif
9431                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9432               endif
9433             else
9434 #ifdef MOMENT
9435               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9436 #else
9437               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9438 #endif
9439               if (l.eq.j+1) then
9440                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9441               else
9442                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9443               endif
9444             endif
9445           enddo
9446         enddo
9447       enddo
9448       return
9449       end
9450 c----------------------------------------------------------------------------
9451       double precision function eello_turn6(i,jj,kk)
9452       implicit real*8 (a-h,o-z)
9453       include 'DIMENSIONS'
9454       include 'COMMON.IOUNITS'
9455       include 'COMMON.CHAIN'
9456       include 'COMMON.DERIV'
9457       include 'COMMON.INTERACT'
9458       include 'COMMON.CONTACTS'
9459       include 'COMMON.TORSION'
9460       include 'COMMON.VAR'
9461       include 'COMMON.GEO'
9462       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9463      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9464      &  ggg1(3),ggg2(3)
9465       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9466      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9467 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9468 C           the respective energy moment and not to the cluster cumulant.
9469       s1=0.0d0
9470       s8=0.0d0
9471       s13=0.0d0
9472 c
9473       eello_turn6=0.0d0
9474       j=i+4
9475       k=i+1
9476       l=i+3
9477       iti=itortyp(itype(i))
9478       itk=itortyp(itype(k))
9479       itk1=itortyp(itype(k+1))
9480       itl=itortyp(itype(l))
9481       itj=itortyp(itype(j))
9482 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9483 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9484 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9485 cd        eello6=0.0d0
9486 cd        return
9487 cd      endif
9488 cd      write (iout,*)
9489 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9490 cd     &   ' and',k,l
9491 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9492       do iii=1,2
9493         do kkk=1,5
9494           do lll=1,3
9495             derx_turn(lll,kkk,iii)=0.0d0
9496           enddo
9497         enddo
9498       enddo
9499 cd      eij=1.0d0
9500 cd      ekl=1.0d0
9501 cd      ekont=1.0d0
9502       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9503 cd      eello6_5=0.0d0
9504 cd      write (2,*) 'eello6_5',eello6_5
9505 #ifdef MOMENT
9506       call transpose2(AEA(1,1,1),auxmat(1,1))
9507       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9508       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9509       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9510 #endif
9511       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9512       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9513       s2 = scalar2(b1(1,itk),vtemp1(1))
9514 #ifdef MOMENT
9515       call transpose2(AEA(1,1,2),atemp(1,1))
9516       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9517       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9518       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9519 #endif
9520       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9521       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9522       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9523 #ifdef MOMENT
9524       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9525       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9526       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9527       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9528       ss13 = scalar2(b1(1,itk),vtemp4(1))
9529       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9530 #endif
9531 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9532 c      s1=0.0d0
9533 c      s2=0.0d0
9534 c      s8=0.0d0
9535 c      s12=0.0d0
9536 c      s13=0.0d0
9537       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9538 C Derivatives in gamma(i+2)
9539       s1d =0.0d0
9540       s8d =0.0d0
9541 #ifdef MOMENT
9542       call transpose2(AEA(1,1,1),auxmatd(1,1))
9543       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9544       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9545       call transpose2(AEAderg(1,1,2),atempd(1,1))
9546       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9547       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9548 #endif
9549       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9550       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9551       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9552 c      s1d=0.0d0
9553 c      s2d=0.0d0
9554 c      s8d=0.0d0
9555 c      s12d=0.0d0
9556 c      s13d=0.0d0
9557       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9558 C Derivatives in gamma(i+3)
9559 #ifdef MOMENT
9560       call transpose2(AEA(1,1,1),auxmatd(1,1))
9561       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9562       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9563       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9564 #endif
9565       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9566       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9567       s2d = scalar2(b1(1,itk),vtemp1d(1))
9568 #ifdef MOMENT
9569       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9570       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9571 #endif
9572       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9573 #ifdef MOMENT
9574       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9575       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9576       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9577 #endif
9578 c      s1d=0.0d0
9579 c      s2d=0.0d0
9580 c      s8d=0.0d0
9581 c      s12d=0.0d0
9582 c      s13d=0.0d0
9583 #ifdef MOMENT
9584       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9585      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9586 #else
9587       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9588      &               -0.5d0*ekont*(s2d+s12d)
9589 #endif
9590 C Derivatives in gamma(i+4)
9591       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9592       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9593       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9594 #ifdef MOMENT
9595       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9596       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9597       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9598 #endif
9599 c      s1d=0.0d0
9600 c      s2d=0.0d0
9601 c      s8d=0.0d0
9602 C      s12d=0.0d0
9603 c      s13d=0.0d0
9604 #ifdef MOMENT
9605       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9606 #else
9607       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9608 #endif
9609 C Derivatives in gamma(i+5)
9610 #ifdef MOMENT
9611       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9612       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9613       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9614 #endif
9615       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9616       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9617       s2d = scalar2(b1(1,itk),vtemp1d(1))
9618 #ifdef MOMENT
9619       call transpose2(AEA(1,1,2),atempd(1,1))
9620       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9621       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9622 #endif
9623       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9624       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9625 #ifdef MOMENT
9626       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9627       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9628       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9629 #endif
9630 c      s1d=0.0d0
9631 c      s2d=0.0d0
9632 c      s8d=0.0d0
9633 c      s12d=0.0d0
9634 c      s13d=0.0d0
9635 #ifdef MOMENT
9636       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9637      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9638 #else
9639       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9640      &               -0.5d0*ekont*(s2d+s12d)
9641 #endif
9642 C Cartesian derivatives
9643       do iii=1,2
9644         do kkk=1,5
9645           do lll=1,3
9646 #ifdef MOMENT
9647             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9648             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9649             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9650 #endif
9651             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9652             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9653      &          vtemp1d(1))
9654             s2d = scalar2(b1(1,itk),vtemp1d(1))
9655 #ifdef MOMENT
9656             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9657             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9658             s8d = -(atempd(1,1)+atempd(2,2))*
9659      &           scalar2(cc(1,1,itl),vtemp2(1))
9660 #endif
9661             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9662      &           auxmatd(1,1))
9663             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9664             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9665 c      s1d=0.0d0
9666 c      s2d=0.0d0
9667 c      s8d=0.0d0
9668 c      s12d=0.0d0
9669 c      s13d=0.0d0
9670 #ifdef MOMENT
9671             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9672      &        - 0.5d0*(s1d+s2d)
9673 #else
9674             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9675      &        - 0.5d0*s2d
9676 #endif
9677 #ifdef MOMENT
9678             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9679      &        - 0.5d0*(s8d+s12d)
9680 #else
9681             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9682      &        - 0.5d0*s12d
9683 #endif
9684           enddo
9685         enddo
9686       enddo
9687 #ifdef MOMENT
9688       do kkk=1,5
9689         do lll=1,3
9690           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9691      &      achuj_tempd(1,1))
9692           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9693           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9694           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9695           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9696           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9697      &      vtemp4d(1))
9698           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9699           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9700           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9701         enddo
9702       enddo
9703 #endif
9704 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9705 cd     &  16*eel_turn6_num
9706 cd      goto 1112
9707       if (j.lt.nres-1) then
9708         j1=j+1
9709         j2=j-1
9710       else
9711         j1=j-1
9712         j2=j-2
9713       endif
9714       if (l.lt.nres-1) then
9715         l1=l+1
9716         l2=l-1
9717       else
9718         l1=l-1
9719         l2=l-2
9720       endif
9721       do ll=1,3
9722 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9723 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9724 cgrad        ghalf=0.5d0*ggg1(ll)
9725 cd        ghalf=0.0d0
9726         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9727         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9728         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9729      &    +ekont*derx_turn(ll,2,1)
9730         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9731         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9732      &    +ekont*derx_turn(ll,4,1)
9733         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9734         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9735         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9736 cgrad        ghalf=0.5d0*ggg2(ll)
9737 cd        ghalf=0.0d0
9738         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9739      &    +ekont*derx_turn(ll,2,2)
9740         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9741         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9742      &    +ekont*derx_turn(ll,4,2)
9743         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9744         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9745         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9746       enddo
9747 cd      goto 1112
9748 cgrad      do m=i+1,j-1
9749 cgrad        do ll=1,3
9750 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9751 cgrad        enddo
9752 cgrad      enddo
9753 cgrad      do m=k+1,l-1
9754 cgrad        do ll=1,3
9755 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9756 cgrad        enddo
9757 cgrad      enddo
9758 cgrad1112  continue
9759 cgrad      do m=i+2,j2
9760 cgrad        do ll=1,3
9761 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9762 cgrad        enddo
9763 cgrad      enddo
9764 cgrad      do m=k+2,l2
9765 cgrad        do ll=1,3
9766 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9767 cgrad        enddo
9768 cgrad      enddo
9769 cd      do iii=1,nres-3
9770 cd        write (2,*) iii,g_corr6_loc(iii)
9771 cd      enddo
9772       eello_turn6=ekont*eel_turn6
9773 cd      write (2,*) 'ekont',ekont
9774 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9775       return
9776       end
9777
9778 C-----------------------------------------------------------------------------
9779       double precision function scalar(u,v)
9780 !DIR$ INLINEALWAYS scalar
9781 #ifndef OSF
9782 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9783 #endif
9784       implicit none
9785       double precision u(3),v(3)
9786 cd      double precision sc
9787 cd      integer i
9788 cd      sc=0.0d0
9789 cd      do i=1,3
9790 cd        sc=sc+u(i)*v(i)
9791 cd      enddo
9792 cd      scalar=sc
9793
9794       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9795       return
9796       end
9797 crc-------------------------------------------------
9798       SUBROUTINE MATVEC2(A1,V1,V2)
9799 !DIR$ INLINEALWAYS MATVEC2
9800 #ifndef OSF
9801 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9802 #endif
9803       implicit real*8 (a-h,o-z)
9804       include 'DIMENSIONS'
9805       DIMENSION A1(2,2),V1(2),V2(2)
9806 c      DO 1 I=1,2
9807 c        VI=0.0
9808 c        DO 3 K=1,2
9809 c    3     VI=VI+A1(I,K)*V1(K)
9810 c        Vaux(I)=VI
9811 c    1 CONTINUE
9812
9813       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9814       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9815
9816       v2(1)=vaux1
9817       v2(2)=vaux2
9818       END
9819 C---------------------------------------
9820       SUBROUTINE MATMAT2(A1,A2,A3)
9821 #ifndef OSF
9822 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9823 #endif
9824       implicit real*8 (a-h,o-z)
9825       include 'DIMENSIONS'
9826       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9827 c      DIMENSION AI3(2,2)
9828 c        DO  J=1,2
9829 c          A3IJ=0.0
9830 c          DO K=1,2
9831 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9832 c          enddo
9833 c          A3(I,J)=A3IJ
9834 c       enddo
9835 c      enddo
9836
9837       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9838       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9839       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9840       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9841
9842       A3(1,1)=AI3_11
9843       A3(2,1)=AI3_21
9844       A3(1,2)=AI3_12
9845       A3(2,2)=AI3_22
9846       END
9847
9848 c-------------------------------------------------------------------------
9849       double precision function scalar2(u,v)
9850 !DIR$ INLINEALWAYS scalar2
9851       implicit none
9852       double precision u(2),v(2)
9853       double precision sc
9854       integer i
9855       scalar2=u(1)*v(1)+u(2)*v(2)
9856       return
9857       end
9858
9859 C-----------------------------------------------------------------------------
9860
9861       subroutine transpose2(a,at)
9862 !DIR$ INLINEALWAYS transpose2
9863 #ifndef OSF
9864 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9865 #endif
9866       implicit none
9867       double precision a(2,2),at(2,2)
9868       at(1,1)=a(1,1)
9869       at(1,2)=a(2,1)
9870       at(2,1)=a(1,2)
9871       at(2,2)=a(2,2)
9872       return
9873       end
9874 c--------------------------------------------------------------------------
9875       subroutine transpose(n,a,at)
9876       implicit none
9877       integer n,i,j
9878       double precision a(n,n),at(n,n)
9879       do i=1,n
9880         do j=1,n
9881           at(j,i)=a(i,j)
9882         enddo
9883       enddo
9884       return
9885       end
9886 C---------------------------------------------------------------------------
9887       subroutine prodmat3(a1,a2,kk,transp,prod)
9888 !DIR$ INLINEALWAYS prodmat3
9889 #ifndef OSF
9890 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9891 #endif
9892       implicit none
9893       integer i,j
9894       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9895       logical transp
9896 crc      double precision auxmat(2,2),prod_(2,2)
9897
9898       if (transp) then
9899 crc        call transpose2(kk(1,1),auxmat(1,1))
9900 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9901 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9902
9903            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9904      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9905            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9906      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9907            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9908      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9909            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9910      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9911
9912       else
9913 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9914 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9915
9916            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9917      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9918            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9919      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9920            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9921      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9922            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9923      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9924
9925       endif
9926 c      call transpose2(a2(1,1),a2t(1,1))
9927
9928 crc      print *,transp
9929 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9930 crc      print *,((prod(i,j),i=1,2),j=1,2)
9931
9932       return
9933       end
9934