source/unres/src_MD-DFA-restraints/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      print *,'Processor',myrank,' calling etotal ipot=',ipot
  96 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  97 #else
  98 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  99 c        call int_from_cart1(.false.)
 100 c      endif
 101 #endif
 102 #ifdef TIMING
 103 #ifdef MPI
 104       time00=MPI_Wtime()
 105 #else
 106       time00=tcpu()
 107 #endif
 108 #endif
 109 C
 110 C Compute the side-chain and electrostatic interaction energy
 111 C
 112       goto (101,102,103,104,105,106) ipot
 113 C Lennard-Jones potential.
 114   101 call elj(evdw,evdw_p,evdw_m)
 115 cd    print '(a)','Exit ELJ'
 116       goto 107
 117 C Lennard-Jones-Kihara potential (shifted).
 118   102 call eljk(evdw,evdw_p,evdw_m)
 119       goto 107
 120 C Berne-Pechukas potential (dilated LJ, angular dependence).
 121   103 call ebp(evdw,evdw_p,evdw_m)
 122       goto 107
 123 C Gay-Berne potential (shifted LJ, angular dependence).
 124   104 call egb(evdw,evdw_p,evdw_m)
 125       goto 107
 126 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 127   105 call egbv(evdw,evdw_p,evdw_m)
 128       goto 107
 129 C Soft-sphere potential
 130   106 call e_softsphere(evdw)
 131 C
 132 C Calculate electrostatic (H-bonding) energy of the main chain.
 133 C
 134   107 continue
 135 C     BARTEK for dfa test!
 136       if (wdfa_dist.gt.0) then
 137         call edfad(edfadis)
 138       else
 139         edfadis=0
 140       endif
 141 c      print*, 'edfad is finished!', edfadis
 142       if (wdfa_tor.gt.0) then
 143         call edfat(edfator)
 144       else
 145         edfator=0
 146       endif
 147 c      print*, 'edfat is finished!', edfator
 148       if (wdfa_nei.gt.0) then
 149         call edfan(edfanei)
 150       else
 151         edfanei=0
 152       endif
 153 c      print*, 'edfan is finished!', edfanei
 154       if (wdfa_beta.gt.0) then
 155         call edfab(edfabet)
 156       else
 157         edfabet=0
 158       endif
 159 c      print*, 'edfab is finished!', edfabet
 160 cmc
 161 cmc Sep-06: egb takes care of dynamic ss bonds too
 162 cmc
 163 c      if (dyn_ss) call dyn_set_nss
 164
 165 c      print *,"Processor",myrank," computed USCSC"
 166 #ifdef TIMING
 167 #ifdef MPI
 168       time01=MPI_Wtime()
 169 #else
 170       time00=tcpu()
 171 #endif
 172 #endif
 173       call vec_and_deriv
 174 #ifdef TIMING
 175 #ifdef MPI
 176       time_vec=time_vec+MPI_Wtime()-time01
 177 #else
 178       time_vec=time_vec+tcpu()-time01
 179 #endif
 180 #endif
 181 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 182       if (ipot.lt.6) then
 183 #ifdef SPLITELE
 184          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 185      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 186      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 187      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 188 #else
 189          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 190      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 191      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 192      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 193 #endif
 194             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 195          else
 196             ees=0.0d0
 197             evdw1=0.0d0
 198             eel_loc=0.0d0
 199             eello_turn3=0.0d0
 200             eello_turn4=0.0d0
 201          endif
 202       else
 203 c        write (iout,*) "Soft-spheer ELEC potential"
 204         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 205      &   eello_turn4)
 206       endif
 207 c      print *,"Processor",myrank," computed UELEC"
 208 C
 209 C Calculate excluded-volume interaction energy between peptide groups
 210 C and side chains.
 211 C
 212       if (ipot.lt.6) then
 213        if(wscp.gt.0d0) then
 214         call escp(evdw2,evdw2_14)
 215        else
 216         evdw2=0
 217         evdw2_14=0
 218        endif
 219       else
 220 c        write (iout,*) "Soft-sphere SCP potential"
 221         call escp_soft_sphere(evdw2,evdw2_14)
 222       endif
 223 c
 224 c Calculate the bond-stretching energy
 225 c
 226       call ebond(estr)
 227 C
 228 C Calculate the disulfide-bridge and other energy and the contributions
 229 C from other distance constraints.
 230 cd    print *,'Calling EHPB'
 231       call edis(ehpb)
 232 cd    print *,'EHPB exitted succesfully.'
 233 C
 234 C Calculate the virtual-bond-angle energy.
 235 C
 236       if (wang.gt.0d0) then
 237         call ebend(ebe)
 238       else
 239         ebe=0
 240       endif
 241 c      print *,"Processor",myrank," computed UB"
 242 C
 243 C Calculate the SC local energy.
 244 C
 245       call esc(escloc)
 246 c      print *,"Processor",myrank," computed USC"
 247 C
 248 C Calculate the virtual-bond torsional energy.
 249 C
 250 cd    print *,'nterm=',nterm
 251       if (wtor.gt.0) then
 252        call etor(etors,edihcnstr)
 253       else
 254        etors=0
 255        edihcnstr=0
 256       endif
 257
 258       if (constr_homology.ge.1) then
 259         call e_modeller(ehomology_constr)
 260       else
 261         ehomology_constr=0.0d0
 262       endif
 263
 264
 265 c      write(iout,*) ehomology_constr
 266 c      print *,"Processor",myrank," computed Utor"
 267 C
 268 C 6/23/01 Calculate double-torsional energy
 269 C
 270       if (wtor_d.gt.0) then
 271        call etor_d(etors_d)
 272       else
 273        etors_d=0
 274       endif
 275 c      print *,"Processor",myrank," computed Utord"
 276 C
 277 C 21/5/07 Calculate local sicdechain correlation energy
 278 C
 279       if (wsccor.gt.0.0d0) then
 280         call eback_sc_corr(esccor)
 281       else
 282         esccor=0.0d0
 283       endif
 284 c      print *,"Processor",myrank," computed Usccorr"
 285 C
 286 C 12/1/95 Multi-body terms
 287 C
 288       n_corr=0
 289       n_corr1=0
 290       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 291      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 292          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 293 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 294 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 295       else
 296          ecorr=0.0d0
 297          ecorr5=0.0d0
 298          ecorr6=0.0d0
 299          eturn6=0.0d0
 300       endif
 301       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 302          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 303 cd         write (iout,*) "multibody_hb ecorr",ecorr
 304       endif
 305 c      print *,"Processor",myrank," computed Ucorr"
 306 C
 307 C If performing constraint dynamics, call the constraint energy
 308 C  after the equilibration time
 309       if(usampl.and.totT.gt.eq_time) then
 310          call EconstrQ
 311          call Econstr_back
 312       else
 313          Uconst=0.0d0
 314          Uconst_back=0.0d0
 315       endif
 316 #ifdef TIMING
 317 #ifdef MPI
 318       time_enecalc=time_enecalc+MPI_Wtime()-time00
 319 #else
 320       time_enecalc=time_enecalc+tcpu()-time00
 321 #endif
 322 #endif
 323 c      print *,"Processor",myrank," computed Uconstr"
 324 #ifdef TIMING
 325 #ifdef MPI
 326       time00=MPI_Wtime()
 327 #else
 328       time00=tcpu()
 329 #endif
 330 #endif
 331 c
 332 C Sum the energies
 333 C
 334       energia(1)=evdw
 335 #ifdef SCP14
 336       energia(2)=evdw2-evdw2_14
 337       energia(18)=evdw2_14
 338 #else
 339       energia(2)=evdw2
 340       energia(18)=0.0d0
 341 #endif
 342 #ifdef SPLITELE
 343       energia(3)=ees
 344       energia(16)=evdw1
 345 #else
 346       energia(3)=ees+evdw1
 347       energia(16)=0.0d0
 348 #endif
 349       energia(4)=ecorr
 350       energia(5)=ecorr5
 351       energia(6)=ecorr6
 352       energia(7)=eel_loc
 353       energia(8)=eello_turn3
 354       energia(9)=eello_turn4
 355       energia(10)=eturn6
 356       energia(11)=ebe
 357       energia(12)=escloc
 358       energia(13)=etors
 359       energia(14)=etors_d
 360       energia(15)=ehpb
 361       energia(19)=edihcnstr
 362       energia(17)=estr
 363       energia(20)=Uconst+Uconst_back
 364       energia(21)=esccor
 365       energia(22)=evdw_p
 366       energia(23)=evdw_m
 367       energia(24)=ehomology_constr
 368       energia(25)=edfadis
 369       energia(26)=edfator
 370       energia(27)=edfanei
 371       energia(28)=edfabet
 372 c      print *," Processor",myrank," calls SUM_ENERGY"
 373       call sum_energy(energia,.true.)
 374       if (dyn_ss) call dyn_set_nss
 375 c      print *," Processor",myrank," left SUM_ENERGY"
 376 #ifdef TIMING
 377 #ifdef MPI
 378       time_sumene=time_sumene+MPI_Wtime()-time00
 379 #else
 380       time_sumene=time_sumene+tcpu()-time00
 381 #endif
 382 #endif
 383       return
 384       end
 385 c-------------------------------------------------------------------------------
 386       subroutine sum_energy(energia,reduce)
 387       implicit real*8 (a-h,o-z)
 388       include 'DIMENSIONS'
 389 #ifndef ISNAN
 390       external proc_proc
 391 #ifdef WINPGI
 392 cMS$ATTRIBUTES C ::  proc_proc
 393 #endif
 394 #endif
 395 #ifdef MPI
 396       include "mpif.h"
 397 #endif
 398       include 'COMMON.SETUP'
 399       include 'COMMON.IOUNITS'
 400       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 401       include 'COMMON.FFIELD'
 402       include 'COMMON.DERIV'
 403       include 'COMMON.INTERACT'
 404       include 'COMMON.SBRIDGE'
 405       include 'COMMON.CHAIN'
 406       include 'COMMON.VAR'
 407       include 'COMMON.CONTROL'
 408       include 'COMMON.TIME1'
 409       logical reduce
 410 #ifdef MPI
 411       if (nfgtasks.gt.1 .and. reduce) then
 412 #ifdef DEBUG
 413         write (iout,*) "energies before REDUCE"
 414         call enerprint(energia)
 415         call flush(iout)
 416 #endif
 417         do i=0,n_ene
 418           enebuff(i)=energia(i)
 419         enddo
 420         time00=MPI_Wtime()
 421         call MPI_Barrier(FG_COMM,IERR)
 422         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 423         time00=MPI_Wtime()
 424         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 425      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 426 #ifdef DEBUG
 427         write (iout,*) "energies after REDUCE"
 428         call enerprint(energia)
 429         call flush(iout)
 430 #endif
 431         time_Reduce=time_Reduce+MPI_Wtime()-time00
 432       endif
 433       if (fg_rank.eq.0) then
 434 #endif
 435 #ifdef TSCSC
 436       evdw=energia(22)+wsct*energia(23)
 437 #else
 438       evdw=energia(1)
 439 #endif
 440 #ifdef SCP14
 441       evdw2=energia(2)+energia(18)
 442       evdw2_14=energia(18)
 443 #else
 444       evdw2=energia(2)
 445 #endif
 446 #ifdef SPLITELE
 447       ees=energia(3)
 448       evdw1=energia(16)
 449 #else
 450       ees=energia(3)
 451       evdw1=0.0d0
 452 #endif
 453       ecorr=energia(4)
 454       ecorr5=energia(5)
 455       ecorr6=energia(6)
 456       eel_loc=energia(7)
 457       eello_turn3=energia(8)
 458       eello_turn4=energia(9)
 459       eturn6=energia(10)
 460       ebe=energia(11)
 461       escloc=energia(12)
 462       etors=energia(13)
 463       etors_d=energia(14)
 464       ehpb=energia(15)
 465       edihcnstr=energia(19)
 466       estr=energia(17)
 467       Uconst=energia(20)
 468       esccor=energia(21)
 469       ehomology_constr=energia(24)
 470       edfadis=energia(25)
 471       edfator=energia(26)
 472       edfanei=energia(27)
 473       edfabet=energia(28)
 474 #ifdef SPLITELE
 475       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 476      & +wang*ebe+wtor*etors+wscloc*escloc
 477      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 478      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 479      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 480      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 481      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 482      & +wdfa_beta*edfabet
 483 #else
 484       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 485      & +wang*ebe+wtor*etors+wscloc*escloc
 486      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 487      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 488      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 489      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 490      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 491      & +wdfa_beta*edfabet
 492 #endif
 493       energia(0)=etot
 494 c detecting NaNQ
 495 #ifdef ISNAN
 496 #ifdef AIX
 497       if (isnan(etot).ne.0) energia(0)=1.0d+99
 498 #else
 499       if (isnan(etot)) energia(0)=1.0d+99
 500 #endif
 501 #else
 502       i=0
 503 #ifdef WINPGI
 504       idumm=proc_proc(etot,i)
 505 #else
 506       call proc_proc(etot,i)
 507 #endif
 508       if(i.eq.1)energia(0)=1.0d+99
 509 #endif
 510 #ifdef MPI
 511       endif
 512 #endif
 513       return
 514       end
 515 c-------------------------------------------------------------------------------
 516       subroutine sum_gradient
 517       implicit real*8 (a-h,o-z)
 518       include 'DIMENSIONS'
 519 #ifndef ISNAN
 520       external proc_proc
 521 #ifdef WINPGI
 522 cMS$ATTRIBUTES C ::  proc_proc
 523 #endif
 524 #endif
 525 #ifdef MPI
 526       include 'mpif.h'
 527 #endif
 528       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 529      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 530       include 'COMMON.SETUP'
 531       include 'COMMON.IOUNITS'
 532       include 'COMMON.FFIELD'
 533       include 'COMMON.DERIV'
 534       include 'COMMON.INTERACT'
 535       include 'COMMON.SBRIDGE'
 536       include 'COMMON.CHAIN'
 537       include 'COMMON.VAR'
 538       include 'COMMON.CONTROL'
 539       include 'COMMON.TIME1'
 540       include 'COMMON.MAXGRAD'
 541       include 'COMMON.SCCOR'
 542 #ifdef TIMING
 543 #ifdef MPI
 544       time01=MPI_Wtime()
 545 #else
 546       time01=tcpu()
 547 #endif
 548 #endif
 549 #ifdef DEBUG
 550       write (iout,*) "sum_gradient gvdwc, gvdwx"
 551       do i=1,nres
 552         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 553      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 554      &   (gvdwcT(j,i),j=1,3)
 555       enddo
 556       call flush(iout)
 557 #endif
 558 #ifdef MPI
 559 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 560         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 561      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 562 #endif
 563 C
 564 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 565 C            in virtual-bond-vector coordinates
 566 C
 567 #ifdef DEBUG
 568 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 569 c      do i=1,nres-1
 570 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 571 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 572 c      enddo
 573 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 574 c      do i=1,nres-1
 575 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 576 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 577 c      enddo
 578       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 579       do i=1,nres
 580         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 581      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 582      &   g_corr5_loc(i)
 583       enddo
 584       call flush(iout)
 585 #endif
 586 #ifdef SPLITELE
 587 #ifdef TSCSC
 588       do i=1,nct
 589         do j=1,3
 590           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 591      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 592      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 593      &                wel_loc*gel_loc_long(j,i)+
 594      &                wcorr*gradcorr_long(j,i)+
 595      &                wcorr5*gradcorr5_long(j,i)+
 596      &                wcorr6*gradcorr6_long(j,i)+
 597      &                wturn6*gcorr6_turn_long(j,i)+
 598      &                wstrain*ghpbc(j,i)+
 599      &                wdfa_dist*gdfad(j,i)+
 600      &                wdfa_tor*gdfat(j,i)+
 601      &                wdfa_nei*gdfan(j,i)+
 602      &                wdfa_beta*gdfab(j,i)
 603         enddo
 604       enddo
 605 #else
 606       do i=1,nct
 607         do j=1,3
 608           gradbufc(j,i)=wsc*gvdwc(j,i)+
 609      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 610      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 611      &                wel_loc*gel_loc_long(j,i)+
 612      &                wcorr*gradcorr_long(j,i)+
 613      &                wcorr5*gradcorr5_long(j,i)+
 614      &                wcorr6*gradcorr6_long(j,i)+
 615      &                wturn6*gcorr6_turn_long(j,i)+
 616      &                wstrain*ghpbc(j,i)+
 617      &                wdfa_dist*gdfad(j,i)+
 618      &                wdfa_tor*gdfat(j,i)+
 619      &                wdfa_nei*gdfan(j,i)+
 620      &                wdfa_beta*gdfab(j,i)
 621         enddo
 622       enddo
 623 #endif
 624 #else
 625       do i=1,nct
 626         do j=1,3
 627           gradbufc(j,i)=wsc*gvdwc(j,i)+
 628      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 629      &                welec*gelc_long(j,i)+
 630      &                wbond*gradb(j,i)+
 631      &                wel_loc*gel_loc_long(j,i)+
 632      &                wcorr*gradcorr_long(j,i)+
 633      &                wcorr5*gradcorr5_long(j,i)+
 634      &                wcorr6*gradcorr6_long(j,i)+
 635      &                wturn6*gcorr6_turn_long(j,i)+
 636      &                wstrain*ghpbc(j,i)+
 637      &                wdfa_dist*gdfad(j,i)+
 638      &                wdfa_tor*gdfat(j,i)+
 639      &                wdfa_nei*gdfan(j,i)+
 640      &                wdfa_beta*gdfab(j,i)
 641         enddo
 642       enddo
 643 #endif
 644 #ifdef MPI
 645       if (nfgtasks.gt.1) then
 646       time00=MPI_Wtime()
 647 #ifdef DEBUG
 648       write (iout,*) "gradbufc before allreduce"
 649       do i=1,nres
 650         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 651       enddo
 652       call flush(iout)
 653 #endif
 654       do i=1,nres
 655         do j=1,3
 656           gradbufc_sum(j,i)=gradbufc(j,i)
 657         enddo
 658       enddo
 659 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 660 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 661 c      time_reduce=time_reduce+MPI_Wtime()-time00
 662 #ifdef DEBUG
 663 c      write (iout,*) "gradbufc_sum after allreduce"
 664 c      do i=1,nres
 665 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 666 c      enddo
 667 c      call flush(iout)
 668 #endif
 669 #ifdef TIMING
 670 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 671 #endif
 672       do i=nnt,nres
 673         do k=1,3
 674           gradbufc(k,i)=0.0d0
 675         enddo
 676       enddo
 677 #ifdef DEBUG
 678       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 679       write (iout,*) (i," jgrad_start",jgrad_start(i),
 680      &                  " jgrad_end  ",jgrad_end(i),
 681      &                  i=igrad_start,igrad_end)
 682 #endif
 683 c
 684 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 685 c do not parallelize this part.
 686 c
 687 c      do i=igrad_start,igrad_end
 688 c        do j=jgrad_start(i),jgrad_end(i)
 689 c          do k=1,3
 690 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 691 c          enddo
 692 c        enddo
 693 c      enddo
 694       do j=1,3
 695         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 696       enddo
 697       do i=nres-2,nnt,-1
 698         do j=1,3
 699           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 700         enddo
 701       enddo
 702 #ifdef DEBUG
 703       write (iout,*) "gradbufc after summing"
 704       do i=1,nres
 705         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 706       enddo
 707       call flush(iout)
 708 #endif
 709       else
 710 #endif
 711 #ifdef DEBUG
 712       write (iout,*) "gradbufc"
 713       do i=1,nres
 714         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 715       enddo
 716       call flush(iout)
 717 #endif
 718       do i=1,nres
 719         do j=1,3
 720           gradbufc_sum(j,i)=gradbufc(j,i)
 721           gradbufc(j,i)=0.0d0
 722         enddo
 723       enddo
 724       do j=1,3
 725         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 726       enddo
 727       do i=nres-2,nnt,-1
 728         do j=1,3
 729           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 730         enddo
 731       enddo
 732 c      do i=nnt,nres-1
 733 c        do k=1,3
 734 c          gradbufc(k,i)=0.0d0
 735 c        enddo
 736 c        do j=i+1,nres
 737 c          do k=1,3
 738 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 739 c          enddo
 740 c        enddo
 741 c      enddo
 742 #ifdef DEBUG
 743       write (iout,*) "gradbufc after summing"
 744       do i=1,nres
 745         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 746       enddo
 747       call flush(iout)
 748 #endif
 749 #ifdef MPI
 750       endif
 751 #endif
 752       do k=1,3
 753         gradbufc(k,nres)=0.0d0
 754       enddo
 755       do i=1,nct
 756         do j=1,3
 757 #ifdef SPLITELE
 758           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 759      &                wel_loc*gel_loc(j,i)+
 760      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 761      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 762      &                wel_loc*gel_loc_long(j,i)+
 763      &                wcorr*gradcorr_long(j,i)+
 764      &                wcorr5*gradcorr5_long(j,i)+
 765      &                wcorr6*gradcorr6_long(j,i)+
 766      &                wturn6*gcorr6_turn_long(j,i))+
 767      &                wbond*gradb(j,i)+
 768      &                wcorr*gradcorr(j,i)+
 769      &                wturn3*gcorr3_turn(j,i)+
 770      &                wturn4*gcorr4_turn(j,i)+
 771      &                wcorr5*gradcorr5(j,i)+
 772      &                wcorr6*gradcorr6(j,i)+
 773      &                wturn6*gcorr6_turn(j,i)+
 774      &                wsccor*gsccorc(j,i)
 775      &               +wscloc*gscloc(j,i)
 776 #else
 777           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 778      &                wel_loc*gel_loc(j,i)+
 779      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 780      &                welec*gelc_long(j,i)+
 781      &                wel_loc*gel_loc_long(j,i)+
 782      &                wcorr*gcorr_long(j,i)+
 783      &                wcorr5*gradcorr5_long(j,i)+
 784      &                wcorr6*gradcorr6_long(j,i)+
 785      &                wturn6*gcorr6_turn_long(j,i))+
 786      &                wbond*gradb(j,i)+
 787      &                wcorr*gradcorr(j,i)+
 788      &                wturn3*gcorr3_turn(j,i)+
 789      &                wturn4*gcorr4_turn(j,i)+
 790      &                wcorr5*gradcorr5(j,i)+
 791      &                wcorr6*gradcorr6(j,i)+
 792      &                wturn6*gcorr6_turn(j,i)+
 793      &                wsccor*gsccorc(j,i)
 794      &               +wscloc*gscloc(j,i)
 795 #endif
 796 #ifdef TSCSC
 797           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 798      &                  wscp*gradx_scp(j,i)+
 799      &                  wbond*gradbx(j,i)+
 800      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 801      &                  wsccor*gsccorx(j,i)
 802      &                 +wscloc*gsclocx(j,i)
 803 #else
 804           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 805      &                  wbond*gradbx(j,i)+
 806      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 807      &                  wsccor*gsccorx(j,i)
 808      &                 +wscloc*gsclocx(j,i)
 809 #endif
 810         enddo
 811       enddo
 812 #ifdef DEBUG
 813       write (iout,*) "gloc before adding corr"
 814       do i=1,4*nres
 815         write (iout,*) i,gloc(i,icg)
 816       enddo
 817 #endif
 818       do i=1,nres-3
 819         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 820      &   +wcorr5*g_corr5_loc(i)
 821      &   +wcorr6*g_corr6_loc(i)
 822      &   +wturn4*gel_loc_turn4(i)
 823      &   +wturn3*gel_loc_turn3(i)
 824      &   +wturn6*gel_loc_turn6(i)
 825      &   +wel_loc*gel_loc_loc(i)
 826       enddo
 827 #ifdef DEBUG
 828       write (iout,*) "gloc after adding corr"
 829       do i=1,4*nres
 830         write (iout,*) i,gloc(i,icg)
 831       enddo
 832 #endif
 833 #ifdef MPI
 834       if (nfgtasks.gt.1) then
 835         do j=1,3
 836           do i=1,nres
 837             gradbufc(j,i)=gradc(j,i,icg)
 838             gradbufx(j,i)=gradx(j,i,icg)
 839           enddo
 840         enddo
 841         do i=1,4*nres
 842           glocbuf(i)=gloc(i,icg)
 843         enddo
 844 #ifdef DEBUG
 845       write (iout,*) "gloc_sc before reduce"
 846       do i=1,nres
 847        do j=1,3
 848         write (iout,*) i,j,gloc_sc(j,i,icg)
 849        enddo
 850       enddo
 851 #endif
 852         do i=1,nres
 853          do j=1,3
 854           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 855          enddo
 856         enddo
 857         time00=MPI_Wtime()
 858         call MPI_Barrier(FG_COMM,IERR)
 859         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 860         time00=MPI_Wtime()
 861         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 862      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 863         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 864      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 865         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 866      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 867         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 868      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 869         time_reduce=time_reduce+MPI_Wtime()-time00
 870 #ifdef DEBUG
 871       write (iout,*) "gloc_sc after reduce"
 872       do i=1,nres
 873        do j=1,3
 874         write (iout,*) i,j,gloc_sc(j,i,icg)
 875        enddo
 876       enddo
 877 #endif
 878 #ifdef DEBUG
 879       write (iout,*) "gloc after reduce"
 880       do i=1,4*nres
 881         write (iout,*) i,gloc(i,icg)
 882       enddo
 883 #endif
 884       endif
 885 #endif
 886       if (gnorm_check) then
 887 c
 888 c Compute the maximum elements of the gradient
 889 c
 890       gvdwc_max=0.0d0
 891       gvdwc_scp_max=0.0d0
 892       gelc_max=0.0d0
 893       gvdwpp_max=0.0d0
 894       gradb_max=0.0d0
 895       ghpbc_max=0.0d0
 896       gradcorr_max=0.0d0
 897       gel_loc_max=0.0d0
 898       gcorr3_turn_max=0.0d0
 899       gcorr4_turn_max=0.0d0
 900       gradcorr5_max=0.0d0
 901       gradcorr6_max=0.0d0
 902       gcorr6_turn_max=0.0d0
 903       gsccorc_max=0.0d0
 904       gscloc_max=0.0d0
 905       gvdwx_max=0.0d0
 906       gradx_scp_max=0.0d0
 907       ghpbx_max=0.0d0
 908       gradxorr_max=0.0d0
 909       gsccorx_max=0.0d0
 910       gsclocx_max=0.0d0
 911       do i=1,nct
 912         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 913         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 914 #ifdef TSCSC
 915         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 916         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 917 #endif
 918         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 919         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 920      &   gvdwc_scp_max=gvdwc_scp_norm
 921         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 922         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 923         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 924         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 925         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 926         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 927         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 928         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 929         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 930         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 931         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 932         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 933         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 934      &    gcorr3_turn(1,i)))
 935         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 936      &    gcorr3_turn_max=gcorr3_turn_norm
 937         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 938      &    gcorr4_turn(1,i)))
 939         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 940      &    gcorr4_turn_max=gcorr4_turn_norm
 941         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 942         if (gradcorr5_norm.gt.gradcorr5_max)
 943      &    gradcorr5_max=gradcorr5_norm
 944         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 945         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 946         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 947      &    gcorr6_turn(1,i)))
 948         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 949      &    gcorr6_turn_max=gcorr6_turn_norm
 950         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 951         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 952         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 953         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 954         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 955         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 956 #ifdef TSCSC
 957         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 958         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 959 #endif
 960         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 961         if (gradx_scp_norm.gt.gradx_scp_max)
 962      &    gradx_scp_max=gradx_scp_norm
 963         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 964         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 965         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 966         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 967         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 968         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 969         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 970         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 971       enddo
 972       if (gradout) then
 973 #ifdef AIX
 974         open(istat,file=statname,position="append")
 975 #else
 976         open(istat,file=statname,access="append")
 977 #endif
 978         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 979      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 980      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 981      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 982      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 983      &     gsccorx_max,gsclocx_max
 984         close(istat)
 985         if (gvdwc_max.gt.1.0d4) then
 986           write (iout,*) "gvdwc gvdwx gradb gradbx"
 987           do i=nnt,nct
 988             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 989      &        gradb(j,i),gradbx(j,i),j=1,3)
 990           enddo
 991           call pdbout(0.0d0,'cipiszcze',iout)
 992           call flush(iout)
 993         endif
 994       endif
 995       endif
 996 #ifdef DEBUG
 997       write (iout,*) "gradc gradx gloc"
 998       do i=1,nres
 999         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1000      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1001       enddo
1002 #endif
1003 #ifdef TIMING
1004 #ifdef MPI
1005       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1006 #else
1007       time_sumgradient=time_sumgradient+tcpu()-time01
1008 #endif
1009 #endif
1010       return
1011       end
1012 c-------------------------------------------------------------------------------
1013       subroutine rescale_weights(t_bath)
1014       implicit real*8 (a-h,o-z)
1015       include 'DIMENSIONS'
1016       include 'COMMON.IOUNITS'
1017       include 'COMMON.FFIELD'
1018       include 'COMMON.SBRIDGE'
1019       double precision kfac /2.4d0/
1020       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1021 c      facT=temp0/t_bath
1022 c      facT=2*temp0/(t_bath+temp0)
1023       if (rescale_mode.eq.0) then
1024         facT=1.0d0
1025         facT2=1.0d0
1026         facT3=1.0d0
1027         facT4=1.0d0
1028         facT5=1.0d0
1029       else if (rescale_mode.eq.1) then
1030         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1031         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1032         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1033         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1034         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1035       else if (rescale_mode.eq.2) then
1036         x=t_bath/temp0
1037         x2=x*x
1038         x3=x2*x
1039         x4=x3*x
1040         x5=x4*x
1041         facT=licznik/dlog(dexp(x)+dexp(-x))
1042         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1043         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1044         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1045         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1046       else
1047         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1048         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1049 #ifdef MPI
1050        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1051 #endif
1052        stop 555
1053       endif
1054       welec=weights(3)*fact
1055       wcorr=weights(4)*fact3
1056       wcorr5=weights(5)*fact4
1057       wcorr6=weights(6)*fact5
1058       wel_loc=weights(7)*fact2
1059       wturn3=weights(8)*fact2
1060       wturn4=weights(9)*fact3
1061       wturn6=weights(10)*fact5
1062       wtor=weights(13)*fact
1063       wtor_d=weights(14)*fact2
1064       wsccor=weights(21)*fact
1065 #ifdef TSCSC
1066 c      wsct=t_bath/temp0
1067       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1068 #endif
1069       return
1070       end
1071 C------------------------------------------------------------------------
1072       subroutine enerprint(energia)
1073       implicit real*8 (a-h,o-z)
1074       include 'DIMENSIONS'
1075       include 'COMMON.IOUNITS'
1076       include 'COMMON.FFIELD'
1077       include 'COMMON.SBRIDGE'
1078       include 'COMMON.MD'
1079       double precision energia(0:n_ene)
1080       etot=energia(0)
1081 #ifdef TSCSC
1082       evdw=energia(22)+wsct*energia(23)
1083 #else
1084       evdw=energia(1)
1085 #endif
1086       evdw2=energia(2)
1087 #ifdef SCP14
1088       evdw2=energia(2)+energia(18)
1089 #else
1090       evdw2=energia(2)
1091 #endif
1092       ees=energia(3)
1093 #ifdef SPLITELE
1094       evdw1=energia(16)
1095 #endif
1096       ecorr=energia(4)
1097       ecorr5=energia(5)
1098       ecorr6=energia(6)
1099       eel_loc=energia(7)
1100       eello_turn3=energia(8)
1101       eello_turn4=energia(9)
1102       eello_turn6=energia(10)
1103       ebe=energia(11)
1104       escloc=energia(12)
1105       etors=energia(13)
1106       etors_d=energia(14)
1107       ehpb=energia(15)
1108       edihcnstr=energia(19)
1109       estr=energia(17)
1110       Uconst=energia(20)
1111       esccor=energia(21)
1112       ehomology_constr=energia(24)
1113 C     Bartek
1114       edfadis = energia(25)
1115       edfator = energia(26)
1116       edfanei = energia(27)
1117       edfabet = energia(28)
1118
1119 #ifdef SPLITELE
1120       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1121      &  estr,wbond,ebe,wang,
1122      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1123      &  ecorr,wcorr,
1124      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1125      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1126      &  edihcnstr,ehomology_constr, ebr*nss,
1127      &  Uconst,edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1128      &  edfabet,wdfa_beta,etot
1129    10 format (/'Virtual-chain energies:'//
1130      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1131      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1132      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1133      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1134      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1135      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1136      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1137      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1138      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1139      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1140      & ' (SS bridges & dist. cnstr.)'/
1141      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1142      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1143      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1144      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1145      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1146      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1147      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1148      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1149      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1150      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1151      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1152      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1153      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1154      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1155      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1156      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1157      & 'ETOT=  ',1pE16.6,' (total)')
1158 #else
1159       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1160      &  estr,wbond,ebe,wang,
1161      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1162      &  ecorr,wcorr,
1163      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1164      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1165      &  ehomology_constr,ebr*nss,Uconst,edfadis,wdfa_dist,edfator,
1166      &  wdfa_tor,edfanei,wdfa_nei,edfabet,wdfa_beta,
1167      &  etot
1168    10 format (/'Virtual-chain energies:'//
1169      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1170      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1171      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1172      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1173      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1174      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1175      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1176      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1177      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1178      & ' (SS bridges & dist. cnstr.)'/
1179      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1180      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1181      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1182      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1183      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1184      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1185      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1186      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1187      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1188      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1189      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1190      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1191      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
1192      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
1193      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
1194      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
1195      & 'ETOT=  ',1pE16.6,' (total)')
1196 #endif
1197       return
1198       end
1199 C-----------------------------------------------------------------------
1200       subroutine elj(evdw,evdw_p,evdw_m)
1201 C
1202 C This subroutine calculates the interaction energy of nonbonded side chains
1203 C assuming the LJ potential of interaction.
1204 C
1205       implicit real*8 (a-h,o-z)
1206       include 'DIMENSIONS'
1207       parameter (accur=1.0d-10)
1208       include 'COMMON.GEO'
1209       include 'COMMON.VAR'
1210       include 'COMMON.LOCAL'
1211       include 'COMMON.CHAIN'
1212       include 'COMMON.DERIV'
1213       include 'COMMON.INTERACT'
1214       include 'COMMON.TORSION'
1215       include 'COMMON.SBRIDGE'
1216       include 'COMMON.NAMES'
1217       include 'COMMON.IOUNITS'
1218       include 'COMMON.CONTACTS'
1219       dimension gg(3)
1220 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1221       evdw=0.0D0
1222       do i=iatsc_s,iatsc_e
1223         itypi=itype(i)
1224         itypi1=itype(i+1)
1225         xi=c(1,nres+i)
1226         yi=c(2,nres+i)
1227         zi=c(3,nres+i)
1228 C Change 12/1/95
1229         num_conti=0
1230 C
1231 C Calculate SC interaction energy.
1232 C
1233         do iint=1,nint_gr(i)
1234 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1235 cd   &                  'iend=',iend(i,iint)
1236           do j=istart(i,iint),iend(i,iint)
1237             itypj=itype(j)
1238             xj=c(1,nres+j)-xi
1239             yj=c(2,nres+j)-yi
1240             zj=c(3,nres+j)-zi
1241 C Change 12/1/95 to calculate four-body interactions
1242             rij=xj*xj+yj*yj+zj*zj
1243             rrij=1.0D0/rij
1244 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1245             eps0ij=eps(itypi,itypj)
1246             fac=rrij**expon2
1247             e1=fac*fac*aa(itypi,itypj)
1248             e2=fac*bb(itypi,itypj)
1249             evdwij=e1+e2
1250 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1251 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1252 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1253 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1254 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1255 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1256 #ifdef TSCSC
1257             if (bb(itypi,itypj).gt.0) then
1258                evdw_p=evdw_p+evdwij
1259             else
1260                evdw_m=evdw_m+evdwij
1261             endif
1262 #else
1263             evdw=evdw+evdwij
1264 #endif
1265 C
1266 C Calculate the components of the gradient in DC and X
1267 C
1268             fac=-rrij*(e1+evdwij)
1269             gg(1)=xj*fac
1270             gg(2)=yj*fac
1271             gg(3)=zj*fac
1272 #ifdef TSCSC
1273             if (bb(itypi,itypj).gt.0.0d0) then
1274               do k=1,3
1275                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1276                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1277                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1278                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1279               enddo
1280             else
1281               do k=1,3
1282                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1283                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1284                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1285                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1286               enddo
1287             endif
1288 #else
1289             do k=1,3
1290               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1291               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1292               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1293               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1294             enddo
1295 #endif
1296 cgrad            do k=i,j-1
1297 cgrad              do l=1,3
1298 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1299 cgrad              enddo
1300 cgrad            enddo
1301 C
1302 C 12/1/95, revised on 5/20/97
1303 C
1304 C Calculate the contact function. The ith column of the array JCONT will
1305 C contain the numbers of atoms that make contacts with the atom I (of numbers
1306 C greater than I). The arrays FACONT and GACONT will contain the values of
1307 C the contact function and its derivative.
1308 C
1309 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1310 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1311 C Uncomment next line, if the correlation interactions are contact function only
1312             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1313               rij=dsqrt(rij)
1314               sigij=sigma(itypi,itypj)
1315               r0ij=rs0(itypi,itypj)
1316 C
1317 C Check whether the SC's are not too far to make a contact.
1318 C
1319               rcut=1.5d0*r0ij
1320               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1321 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1322 C
1323               if (fcont.gt.0.0D0) then
1324 C If the SC-SC distance if close to sigma, apply spline.
1325 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1326 cAdam &             fcont1,fprimcont1)
1327 cAdam           fcont1=1.0d0-fcont1
1328 cAdam           if (fcont1.gt.0.0d0) then
1329 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1330 cAdam             fcont=fcont*fcont1
1331 cAdam           endif
1332 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1333 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1334 cga             do k=1,3
1335 cga               gg(k)=gg(k)*eps0ij
1336 cga             enddo
1337 cga             eps0ij=-evdwij*eps0ij
1338 C Uncomment for AL's type of SC correlation interactions.
1339 cadam           eps0ij=-evdwij
1340                 num_conti=num_conti+1
1341                 jcont(num_conti,i)=j
1342                 facont(num_conti,i)=fcont*eps0ij
1343                 fprimcont=eps0ij*fprimcont/rij
1344                 fcont=expon*fcont
1345 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1346 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1347 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1348 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1349                 gacont(1,num_conti,i)=-fprimcont*xj
1350                 gacont(2,num_conti,i)=-fprimcont*yj
1351                 gacont(3,num_conti,i)=-fprimcont*zj
1352 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1353 cd              write (iout,'(2i3,3f10.5)')
1354 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1355               endif
1356             endif
1357           enddo      ! j
1358         enddo        ! iint
1359 C Change 12/1/95
1360         num_cont(i)=num_conti
1361       enddo          ! i
1362       do i=1,nct
1363         do j=1,3
1364           gvdwc(j,i)=expon*gvdwc(j,i)
1365           gvdwx(j,i)=expon*gvdwx(j,i)
1366         enddo
1367       enddo
1368 C******************************************************************************
1369 C
1370 C                              N O T E !!!
1371 C
1372 C To save time, the factor of EXPON has been extracted from ALL components
1373 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1374 C use!
1375 C
1376 C******************************************************************************
1377       return
1378       end
1379 C-----------------------------------------------------------------------------
1380       subroutine eljk(evdw,evdw_p,evdw_m)
1381 C
1382 C This subroutine calculates the interaction energy of nonbonded side chains
1383 C assuming the LJK potential of interaction.
1384 C
1385       implicit real*8 (a-h,o-z)
1386       include 'DIMENSIONS'
1387       include 'COMMON.GEO'
1388       include 'COMMON.VAR'
1389       include 'COMMON.LOCAL'
1390       include 'COMMON.CHAIN'
1391       include 'COMMON.DERIV'
1392       include 'COMMON.INTERACT'
1393       include 'COMMON.IOUNITS'
1394       include 'COMMON.NAMES'
1395       dimension gg(3)
1396       logical scheck
1397 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1398       evdw=0.0D0
1399       do i=iatsc_s,iatsc_e
1400         itypi=itype(i)
1401         itypi1=itype(i+1)
1402         xi=c(1,nres+i)
1403         yi=c(2,nres+i)
1404         zi=c(3,nres+i)
1405 C
1406 C Calculate SC interaction energy.
1407 C
1408         do iint=1,nint_gr(i)
1409           do j=istart(i,iint),iend(i,iint)
1410             itypj=itype(j)
1411             xj=c(1,nres+j)-xi
1412             yj=c(2,nres+j)-yi
1413             zj=c(3,nres+j)-zi
1414             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1415             fac_augm=rrij**expon
1416             e_augm=augm(itypi,itypj)*fac_augm
1417             r_inv_ij=dsqrt(rrij)
1418             rij=1.0D0/r_inv_ij
1419             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1420             fac=r_shift_inv**expon
1421             e1=fac*fac*aa(itypi,itypj)
1422             e2=fac*bb(itypi,itypj)
1423             evdwij=e_augm+e1+e2
1424 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1425 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1426 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1427 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1428 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1429 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1430 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1431 #ifdef TSCSC
1432             if (bb(itypi,itypj).gt.0) then
1433                evdw_p=evdw_p+evdwij
1434             else
1435                evdw_m=evdw_m+evdwij
1436             endif
1437 #else
1438             evdw=evdw+evdwij
1439 #endif
1440 C
1441 C Calculate the components of the gradient in DC and X
1442 C
1443             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1444             gg(1)=xj*fac
1445             gg(2)=yj*fac
1446             gg(3)=zj*fac
1447 #ifdef TSCSC
1448             if (bb(itypi,itypj).gt.0.0d0) then
1449               do k=1,3
1450                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1451                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1452                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1453                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1454               enddo
1455             else
1456               do k=1,3
1457                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1458                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1459                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1460                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1461               enddo
1462             endif
1463 #else
1464             do k=1,3
1465               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1466               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1467               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1468               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1469             enddo
1470 #endif
1471 cgrad            do k=i,j-1
1472 cgrad              do l=1,3
1473 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1474 cgrad              enddo
1475 cgrad            enddo
1476           enddo      ! j
1477         enddo        ! iint
1478       enddo          ! i
1479       do i=1,nct
1480         do j=1,3
1481           gvdwc(j,i)=expon*gvdwc(j,i)
1482           gvdwx(j,i)=expon*gvdwx(j,i)
1483         enddo
1484       enddo
1485       return
1486       end
1487 C-----------------------------------------------------------------------------
1488       subroutine ebp(evdw,evdw_p,evdw_m)
1489 C
1490 C This subroutine calculates the interaction energy of nonbonded side chains
1491 C assuming the Berne-Pechukas potential of interaction.
1492 C
1493       implicit real*8 (a-h,o-z)
1494       include 'DIMENSIONS'
1495       include 'COMMON.GEO'
1496       include 'COMMON.VAR'
1497       include 'COMMON.LOCAL'
1498       include 'COMMON.CHAIN'
1499       include 'COMMON.DERIV'
1500       include 'COMMON.NAMES'
1501       include 'COMMON.INTERACT'
1502       include 'COMMON.IOUNITS'
1503       include 'COMMON.CALC'
1504       common /srutu/ icall
1505 c     double precision rrsave(maxdim)
1506       logical lprn
1507       evdw=0.0D0
1508 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1509       evdw=0.0D0
1510 c     if (icall.eq.0) then
1511 c       lprn=.true.
1512 c     else
1513         lprn=.false.
1514 c     endif
1515       ind=0
1516       do i=iatsc_s,iatsc_e
1517         itypi=itype(i)
1518         itypi1=itype(i+1)
1519         xi=c(1,nres+i)
1520         yi=c(2,nres+i)
1521         zi=c(3,nres+i)
1522         dxi=dc_norm(1,nres+i)
1523         dyi=dc_norm(2,nres+i)
1524         dzi=dc_norm(3,nres+i)
1525 c        dsci_inv=dsc_inv(itypi)
1526         dsci_inv=vbld_inv(i+nres)
1527 C
1528 C Calculate SC interaction energy.
1529 C
1530         do iint=1,nint_gr(i)
1531           do j=istart(i,iint),iend(i,iint)
1532             ind=ind+1
1533             itypj=itype(j)
1534 c            dscj_inv=dsc_inv(itypj)
1535             dscj_inv=vbld_inv(j+nres)
1536             chi1=chi(itypi,itypj)
1537             chi2=chi(itypj,itypi)
1538             chi12=chi1*chi2
1539             chip1=chip(itypi)
1540             chip2=chip(itypj)
1541             chip12=chip1*chip2
1542             alf1=alp(itypi)
1543             alf2=alp(itypj)
1544             alf12=0.5D0*(alf1+alf2)
1545 C For diagnostics only!!!
1546 c           chi1=0.0D0
1547 c           chi2=0.0D0
1548 c           chi12=0.0D0
1549 c           chip1=0.0D0
1550 c           chip2=0.0D0
1551 c           chip12=0.0D0
1552 c           alf1=0.0D0
1553 c           alf2=0.0D0
1554 c           alf12=0.0D0
1555             xj=c(1,nres+j)-xi
1556             yj=c(2,nres+j)-yi
1557             zj=c(3,nres+j)-zi
1558             dxj=dc_norm(1,nres+j)
1559             dyj=dc_norm(2,nres+j)
1560             dzj=dc_norm(3,nres+j)
1561             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1562 cd          if (icall.eq.0) then
1563 cd            rrsave(ind)=rrij
1564 cd          else
1565 cd            rrij=rrsave(ind)
1566 cd          endif
1567             rij=dsqrt(rrij)
1568 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1569             call sc_angular
1570 C Calculate whole angle-dependent part of epsilon and contributions
1571 C to its derivatives
1572             fac=(rrij*sigsq)**expon2
1573             e1=fac*fac*aa(itypi,itypj)
1574             e2=fac*bb(itypi,itypj)
1575             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1576             eps2der=evdwij*eps3rt
1577             eps3der=evdwij*eps2rt
1578             evdwij=evdwij*eps2rt*eps3rt
1579 #ifdef TSCSC
1580             if (bb(itypi,itypj).gt.0) then
1581                evdw_p=evdw_p+evdwij
1582             else
1583                evdw_m=evdw_m+evdwij
1584             endif
1585 #else
1586             evdw=evdw+evdwij
1587 #endif
1588             if (lprn) then
1589             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1590             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1591 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1592 cd     &        restyp(itypi),i,restyp(itypj),j,
1593 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1594 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1595 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1596 cd     &        evdwij
1597             endif
1598 C Calculate gradient components.
1599             e1=e1*eps1*eps2rt**2*eps3rt**2
1600             fac=-expon*(e1+evdwij)
1601             sigder=fac/sigsq
1602             fac=rrij*fac
1603 C Calculate radial part of the gradient
1604             gg(1)=xj*fac
1605             gg(2)=yj*fac
1606             gg(3)=zj*fac
1607 C Calculate the angular part of the gradient and sum add the contributions
1608 C to the appropriate components of the Cartesian gradient.
1609 #ifdef TSCSC
1610             if (bb(itypi,itypj).gt.0) then
1611                call sc_grad
1612             else
1613                call sc_grad_T
1614             endif
1615 #else
1616             call sc_grad
1617 #endif
1618           enddo      ! j
1619         enddo        ! iint
1620       enddo          ! i
1621 c     stop
1622       return
1623       end
1624 C-----------------------------------------------------------------------------
1625       subroutine egb(evdw,evdw_p,evdw_m)
1626 C
1627 C This subroutine calculates the interaction energy of nonbonded side chains
1628 C assuming the Gay-Berne potential of interaction.
1629 C
1630       implicit real*8 (a-h,o-z)
1631       include 'DIMENSIONS'
1632       include 'COMMON.GEO'
1633       include 'COMMON.VAR'
1634       include 'COMMON.LOCAL'
1635       include 'COMMON.CHAIN'
1636       include 'COMMON.DERIV'
1637       include 'COMMON.NAMES'
1638       include 'COMMON.INTERACT'
1639       include 'COMMON.IOUNITS'
1640       include 'COMMON.CALC'
1641       include 'COMMON.CONTROL'
1642       include 'COMMON.SBRIDGE'
1643       logical lprn
1644       evdw=0.0D0
1645 ccccc      energy_dec=.false.
1646 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1647       evdw=0.0D0
1648       evdw_p=0.0D0
1649       evdw_m=0.0D0
1650       lprn=.false.
1651 c     if (icall.eq.0) lprn=.false.
1652       ind=0
1653       do i=iatsc_s,iatsc_e
1654         itypi=itype(i)
1655         itypi1=itype(i+1)
1656         xi=c(1,nres+i)
1657         yi=c(2,nres+i)
1658         zi=c(3,nres+i)
1659         dxi=dc_norm(1,nres+i)
1660         dyi=dc_norm(2,nres+i)
1661         dzi=dc_norm(3,nres+i)
1662 c        dsci_inv=dsc_inv(itypi)
1663         dsci_inv=vbld_inv(i+nres)
1664 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1665 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1666 C
1667 C Calculate SC interaction energy.
1668 C
1669         do iint=1,nint_gr(i)
1670           do j=istart(i,iint),iend(i,iint)
1671             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1672               call dyn_ssbond_ene(i,j,evdwij)
1673               evdw=evdw+evdwij
1674               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1675      &                        'evdw',i,j,evdwij,' ss'
1676             ELSE
1677             ind=ind+1
1678             itypj=itype(j)
1679 c            dscj_inv=dsc_inv(itypj)
1680             dscj_inv=vbld_inv(j+nres)
1681 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1682 c     &       1.0d0/vbld(j+nres)
1683 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1684             sig0ij=sigma(itypi,itypj)
1685             chi1=chi(itypi,itypj)
1686             chi2=chi(itypj,itypi)
1687             chi12=chi1*chi2
1688             chip1=chip(itypi)
1689             chip2=chip(itypj)
1690             chip12=chip1*chip2
1691             alf1=alp(itypi)
1692             alf2=alp(itypj)
1693             alf12=0.5D0*(alf1+alf2)
1694 C For diagnostics only!!!
1695 c           chi1=0.0D0
1696 c           chi2=0.0D0
1697 c           chi12=0.0D0
1698 c           chip1=0.0D0
1699 c           chip2=0.0D0
1700 c           chip12=0.0D0
1701 c           alf1=0.0D0
1702 c           alf2=0.0D0
1703 c           alf12=0.0D0
1704             xj=c(1,nres+j)-xi
1705             yj=c(2,nres+j)-yi
1706             zj=c(3,nres+j)-zi
1707             dxj=dc_norm(1,nres+j)
1708             dyj=dc_norm(2,nres+j)
1709             dzj=dc_norm(3,nres+j)
1710 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1711 c            write (iout,*) "j",j," dc_norm",
1712 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1713             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1714             rij=dsqrt(rrij)
1715 C Calculate angle-dependent terms of energy and contributions to their
1716 C derivatives.
1717             call sc_angular
1718             sigsq=1.0D0/sigsq
1719             sig=sig0ij*dsqrt(sigsq)
1720             rij_shift=1.0D0/rij-sig+sig0ij
1721 c for diagnostics; uncomment
1722 c            rij_shift=1.2*sig0ij
1723 C I hate to put IF's in the loops, but here don't have another choice!!!!
1724             if (rij_shift.le.0.0D0) then
1725               evdw=1.0D20
1726 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1727 cd     &        restyp(itypi),i,restyp(itypj),j,
1728 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1729               return
1730             endif
1731             sigder=-sig*sigsq
1732 c---------------------------------------------------------------
1733             rij_shift=1.0D0/rij_shift
1734             fac=rij_shift**expon
1735             e1=fac*fac*aa(itypi,itypj)
1736             e2=fac*bb(itypi,itypj)
1737             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1738             eps2der=evdwij*eps3rt
1739             eps3der=evdwij*eps2rt
1740 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1741 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1742             evdwij=evdwij*eps2rt*eps3rt
1743 #ifdef TSCSC
1744             if (bb(itypi,itypj).gt.0) then
1745                evdw_p=evdw_p+evdwij
1746             else
1747                evdw_m=evdw_m+evdwij
1748             endif
1749 #else
1750             evdw=evdw+evdwij
1751 #endif
1752             if (lprn) then
1753             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1754             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1755             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1756      &        restyp(itypi),i,restyp(itypj),j,
1757      &        epsi,sigm,chi1,chi2,chip1,chip2,
1758      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1759      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1760      &        evdwij
1761             endif
1762
1763             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1764      &                        'evdw',i,j,evdwij
1765
1766 C Calculate gradient components.
1767             e1=e1*eps1*eps2rt**2*eps3rt**2
1768             fac=-expon*(e1+evdwij)*rij_shift
1769             sigder=fac*sigder
1770             fac=rij*fac
1771 c            fac=0.0d0
1772 C Calculate the radial part of the gradient
1773             gg(1)=xj*fac
1774             gg(2)=yj*fac
1775             gg(3)=zj*fac
1776 C Calculate angular part of the gradient.
1777 #ifdef TSCSC
1778             if (bb(itypi,itypj).gt.0) then
1779                call sc_grad
1780             else
1781                call sc_grad_T
1782             endif
1783 #else
1784             call sc_grad
1785 #endif
1786             ENDIF    ! dyn_ss
1787           enddo      ! j
1788         enddo        ! iint
1789       enddo          ! i
1790 c      write (iout,*) "Number of loop steps in EGB:",ind
1791 cccc      energy_dec=.false.
1792       return
1793       end
1794 C-----------------------------------------------------------------------------
1795       subroutine egbv(evdw,evdw_p,evdw_m)
1796 C
1797 C This subroutine calculates the interaction energy of nonbonded side chains
1798 C assuming the Gay-Berne-Vorobjev potential of interaction.
1799 C
1800       implicit real*8 (a-h,o-z)
1801       include 'DIMENSIONS'
1802       include 'COMMON.GEO'
1803       include 'COMMON.VAR'
1804       include 'COMMON.LOCAL'
1805       include 'COMMON.CHAIN'
1806       include 'COMMON.DERIV'
1807       include 'COMMON.NAMES'
1808       include 'COMMON.INTERACT'
1809       include 'COMMON.IOUNITS'
1810       include 'COMMON.CALC'
1811       common /srutu/ icall
1812       logical lprn
1813       evdw=0.0D0
1814 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1815       evdw=0.0D0
1816       lprn=.false.
1817 c     if (icall.eq.0) lprn=.true.
1818       ind=0
1819       do i=iatsc_s,iatsc_e
1820         itypi=itype(i)
1821         itypi1=itype(i+1)
1822         xi=c(1,nres+i)
1823         yi=c(2,nres+i)
1824         zi=c(3,nres+i)
1825         dxi=dc_norm(1,nres+i)
1826         dyi=dc_norm(2,nres+i)
1827         dzi=dc_norm(3,nres+i)
1828 c        dsci_inv=dsc_inv(itypi)
1829         dsci_inv=vbld_inv(i+nres)
1830 C
1831 C Calculate SC interaction energy.
1832 C
1833         do iint=1,nint_gr(i)
1834           do j=istart(i,iint),iend(i,iint)
1835             ind=ind+1
1836             itypj=itype(j)
1837 c            dscj_inv=dsc_inv(itypj)
1838             dscj_inv=vbld_inv(j+nres)
1839             sig0ij=sigma(itypi,itypj)
1840             r0ij=r0(itypi,itypj)
1841             chi1=chi(itypi,itypj)
1842             chi2=chi(itypj,itypi)
1843             chi12=chi1*chi2
1844             chip1=chip(itypi)
1845             chip2=chip(itypj)
1846             chip12=chip1*chip2
1847             alf1=alp(itypi)
1848             alf2=alp(itypj)
1849             alf12=0.5D0*(alf1+alf2)
1850 C For diagnostics only!!!
1851 c           chi1=0.0D0
1852 c           chi2=0.0D0
1853 c           chi12=0.0D0
1854 c           chip1=0.0D0
1855 c           chip2=0.0D0
1856 c           chip12=0.0D0
1857 c           alf1=0.0D0
1858 c           alf2=0.0D0
1859 c           alf12=0.0D0
1860             xj=c(1,nres+j)-xi
1861             yj=c(2,nres+j)-yi
1862             zj=c(3,nres+j)-zi
1863             dxj=dc_norm(1,nres+j)
1864             dyj=dc_norm(2,nres+j)
1865             dzj=dc_norm(3,nres+j)
1866             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1867             rij=dsqrt(rrij)
1868 C Calculate angle-dependent terms of energy and contributions to their
1869 C derivatives.
1870             call sc_angular
1871             sigsq=1.0D0/sigsq
1872             sig=sig0ij*dsqrt(sigsq)
1873             rij_shift=1.0D0/rij-sig+r0ij
1874 C I hate to put IF's in the loops, but here don't have another choice!!!!
1875             if (rij_shift.le.0.0D0) then
1876               evdw=1.0D20
1877               return
1878             endif
1879             sigder=-sig*sigsq
1880 c---------------------------------------------------------------
1881             rij_shift=1.0D0/rij_shift
1882             fac=rij_shift**expon
1883             e1=fac*fac*aa(itypi,itypj)
1884             e2=fac*bb(itypi,itypj)
1885             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1886             eps2der=evdwij*eps3rt
1887             eps3der=evdwij*eps2rt
1888             fac_augm=rrij**expon
1889             e_augm=augm(itypi,itypj)*fac_augm
1890             evdwij=evdwij*eps2rt*eps3rt
1891 #ifdef TSCSC
1892             if (bb(itypi,itypj).gt.0) then
1893                evdw_p=evdw_p+evdwij+e_augm
1894             else
1895                evdw_m=evdw_m+evdwij+e_augm
1896             endif
1897 #else
1898             evdw=evdw+evdwij+e_augm
1899 #endif
1900             if (lprn) then
1901             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1902             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1903             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1904      &        restyp(itypi),i,restyp(itypj),j,
1905      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1906      &        chi1,chi2,chip1,chip2,
1907      &        eps1,eps2rt**2,eps3rt**2,
1908      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1909      &        evdwij+e_augm
1910             endif
1911 C Calculate gradient components.
1912             e1=e1*eps1*eps2rt**2*eps3rt**2
1913             fac=-expon*(e1+evdwij)*rij_shift
1914             sigder=fac*sigder
1915             fac=rij*fac-2*expon*rrij*e_augm
1916 C Calculate the radial part of the gradient
1917             gg(1)=xj*fac
1918             gg(2)=yj*fac
1919             gg(3)=zj*fac
1920 C Calculate angular part of the gradient.
1921 #ifdef TSCSC
1922             if (bb(itypi,itypj).gt.0) then
1923                call sc_grad
1924             else
1925                call sc_grad_T
1926             endif
1927 #else
1928             call sc_grad
1929 #endif
1930           enddo      ! j
1931         enddo        ! iint
1932       enddo          ! i
1933       end
1934 C-----------------------------------------------------------------------------
1935       subroutine sc_angular
1936 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1937 C om12. Called by ebp, egb, and egbv.
1938       implicit none
1939       include 'COMMON.CALC'
1940       include 'COMMON.IOUNITS'
1941       erij(1)=xj*rij
1942       erij(2)=yj*rij
1943       erij(3)=zj*rij
1944       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1945       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1946       om12=dxi*dxj+dyi*dyj+dzi*dzj
1947       chiom12=chi12*om12
1948 C Calculate eps1(om12) and its derivative in om12
1949       faceps1=1.0D0-om12*chiom12
1950       faceps1_inv=1.0D0/faceps1
1951       eps1=dsqrt(faceps1_inv)
1952 C Following variable is eps1*deps1/dom12
1953       eps1_om12=faceps1_inv*chiom12
1954 c diagnostics only
1955 c      faceps1_inv=om12
1956 c      eps1=om12
1957 c      eps1_om12=1.0d0
1958 c      write (iout,*) "om12",om12," eps1",eps1
1959 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1960 C and om12.
1961       om1om2=om1*om2
1962       chiom1=chi1*om1
1963       chiom2=chi2*om2
1964       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1965       sigsq=1.0D0-facsig*faceps1_inv
1966       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1967       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1968       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1969 c diagnostics only
1970 c      sigsq=1.0d0
1971 c      sigsq_om1=0.0d0
1972 c      sigsq_om2=0.0d0
1973 c      sigsq_om12=0.0d0
1974 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1975 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1976 c     &    " eps1",eps1
1977 C Calculate eps2 and its derivatives in om1, om2, and om12.
1978       chipom1=chip1*om1
1979       chipom2=chip2*om2
1980       chipom12=chip12*om12
1981       facp=1.0D0-om12*chipom12
1982       facp_inv=1.0D0/facp
1983       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1984 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1985 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1986 C Following variable is the square root of eps2
1987       eps2rt=1.0D0-facp1*facp_inv
1988 C Following three variables are the derivatives of the square root of eps
1989 C in om1, om2, and om12.
1990       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1991       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1992       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1993 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1994       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1995 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1996 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1997 c     &  " eps2rt_om12",eps2rt_om12
1998 C Calculate whole angle-dependent part of epsilon and contributions
1999 C to its derivatives
2000       return
2001       end
2002
2003 C----------------------------------------------------------------------------
2004       subroutine sc_grad_T
2005       implicit real*8 (a-h,o-z)
2006       include 'DIMENSIONS'
2007       include 'COMMON.CHAIN'
2008       include 'COMMON.DERIV'
2009       include 'COMMON.CALC'
2010       include 'COMMON.IOUNITS'
2011       double precision dcosom1(3),dcosom2(3)
2012       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2013       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2014       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2015      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2016 c diagnostics only
2017 c      eom1=0.0d0
2018 c      eom2=0.0d0
2019 c      eom12=evdwij*eps1_om12
2020 c end diagnostics
2021 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2022 c     &  " sigder",sigder
2023 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2024 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2025       do k=1,3
2026         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2027         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2028       enddo
2029       do k=1,3
2030         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2031       enddo
2032 c      write (iout,*) "gg",(gg(k),k=1,3)
2033       do k=1,3
2034         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
2035      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2036      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2037         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
2038      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2039      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2040 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2041 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2042 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2043 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2044       enddo
2045 C
2046 C Calculate the components of the gradient in DC and X
2047 C
2048 cgrad      do k=i,j-1
2049 cgrad        do l=1,3
2050 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2051 cgrad        enddo
2052 cgrad      enddo
2053       do l=1,3
2054         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
2055         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
2056       enddo
2057       return
2058       end
2059
2060 C----------------------------------------------------------------------------
2061       subroutine sc_grad
2062       implicit real*8 (a-h,o-z)
2063       include 'DIMENSIONS'
2064       include 'COMMON.CHAIN'
2065       include 'COMMON.DERIV'
2066       include 'COMMON.CALC'
2067       include 'COMMON.IOUNITS'
2068       double precision dcosom1(3),dcosom2(3)
2069       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2070       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2071       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2072      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2073 c diagnostics only
2074 c      eom1=0.0d0
2075 c      eom2=0.0d0
2076 c      eom12=evdwij*eps1_om12
2077 c end diagnostics
2078 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2079 c     &  " sigder",sigder
2080 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2081 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2082       do k=1,3
2083         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2084         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2085       enddo
2086       do k=1,3
2087         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2088       enddo
2089 c      write (iout,*) "gg",(gg(k),k=1,3)
2090       do k=1,3
2091         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2092      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2093      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2094         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2095      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2096      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2097 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2098 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2099 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2100 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2101       enddo
2102 C
2103 C Calculate the components of the gradient in DC and X
2104 C
2105 cgrad      do k=i,j-1
2106 cgrad        do l=1,3
2107 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2108 cgrad        enddo
2109 cgrad      enddo
2110       do l=1,3
2111         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2112         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2113       enddo
2114       return
2115       end
2116 C-----------------------------------------------------------------------
2117       subroutine e_softsphere(evdw)
2118 C
2119 C This subroutine calculates the interaction energy of nonbonded side chains
2120 C assuming the LJ potential of interaction.
2121 C
2122       implicit real*8 (a-h,o-z)
2123       include 'DIMENSIONS'
2124       parameter (accur=1.0d-10)
2125       include 'COMMON.GEO'
2126       include 'COMMON.VAR'
2127       include 'COMMON.LOCAL'
2128       include 'COMMON.CHAIN'
2129       include 'COMMON.DERIV'
2130       include 'COMMON.INTERACT'
2131       include 'COMMON.TORSION'
2132       include 'COMMON.SBRIDGE'
2133       include 'COMMON.NAMES'
2134       include 'COMMON.IOUNITS'
2135       include 'COMMON.CONTACTS'
2136       dimension gg(3)
2137 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2138       evdw=0.0D0
2139       do i=iatsc_s,iatsc_e
2140         itypi=itype(i)
2141         itypi1=itype(i+1)
2142         xi=c(1,nres+i)
2143         yi=c(2,nres+i)
2144         zi=c(3,nres+i)
2145 C
2146 C Calculate SC interaction energy.
2147 C
2148         do iint=1,nint_gr(i)
2149 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2150 cd   &                  'iend=',iend(i,iint)
2151           do j=istart(i,iint),iend(i,iint)
2152             itypj=itype(j)
2153             xj=c(1,nres+j)-xi
2154             yj=c(2,nres+j)-yi
2155             zj=c(3,nres+j)-zi
2156             rij=xj*xj+yj*yj+zj*zj
2157 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2158             r0ij=r0(itypi,itypj)
2159             r0ijsq=r0ij*r0ij
2160 c            print *,i,j,r0ij,dsqrt(rij)
2161             if (rij.lt.r0ijsq) then
2162               evdwij=0.25d0*(rij-r0ijsq)**2
2163               fac=rij-r0ijsq
2164             else
2165               evdwij=0.0d0
2166               fac=0.0d0
2167             endif
2168             evdw=evdw+evdwij
2169 C
2170 C Calculate the components of the gradient in DC and X
2171 C
2172             gg(1)=xj*fac
2173             gg(2)=yj*fac
2174             gg(3)=zj*fac
2175             do k=1,3
2176               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2177               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2178               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2179               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2180             enddo
2181 cgrad            do k=i,j-1
2182 cgrad              do l=1,3
2183 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2184 cgrad              enddo
2185 cgrad            enddo
2186           enddo ! j
2187         enddo ! iint
2188       enddo ! i
2189       return
2190       end
2191 C--------------------------------------------------------------------------
2192       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2193      &              eello_turn4)
2194 C
2195 C Soft-sphere potential of p-p interaction
2196 C
2197       implicit real*8 (a-h,o-z)
2198       include 'DIMENSIONS'
2199       include 'COMMON.CONTROL'
2200       include 'COMMON.IOUNITS'
2201       include 'COMMON.GEO'
2202       include 'COMMON.VAR'
2203       include 'COMMON.LOCAL'
2204       include 'COMMON.CHAIN'
2205       include 'COMMON.DERIV'
2206       include 'COMMON.INTERACT'
2207       include 'COMMON.CONTACTS'
2208       include 'COMMON.TORSION'
2209       include 'COMMON.VECTORS'
2210       include 'COMMON.FFIELD'
2211       dimension ggg(3)
2212 cd      write(iout,*) 'In EELEC_soft_sphere'
2213       ees=0.0D0
2214       evdw1=0.0D0
2215       eel_loc=0.0d0
2216       eello_turn3=0.0d0
2217       eello_turn4=0.0d0
2218       ind=0
2219       do i=iatel_s,iatel_e
2220         dxi=dc(1,i)
2221         dyi=dc(2,i)
2222         dzi=dc(3,i)
2223         xmedi=c(1,i)+0.5d0*dxi
2224         ymedi=c(2,i)+0.5d0*dyi
2225         zmedi=c(3,i)+0.5d0*dzi
2226         num_conti=0
2227 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2228         do j=ielstart(i),ielend(i)
2229           ind=ind+1
2230           iteli=itel(i)
2231           itelj=itel(j)
2232           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2233           r0ij=rpp(iteli,itelj)
2234           r0ijsq=r0ij*r0ij
2235           dxj=dc(1,j)
2236           dyj=dc(2,j)
2237           dzj=dc(3,j)
2238           xj=c(1,j)+0.5D0*dxj-xmedi
2239           yj=c(2,j)+0.5D0*dyj-ymedi
2240           zj=c(3,j)+0.5D0*dzj-zmedi
2241           rij=xj*xj+yj*yj+zj*zj
2242           if (rij.lt.r0ijsq) then
2243             evdw1ij=0.25d0*(rij-r0ijsq)**2
2244             fac=rij-r0ijsq
2245           else
2246             evdw1ij=0.0d0
2247             fac=0.0d0
2248           endif
2249           evdw1=evdw1+evdw1ij
2250 C
2251 C Calculate contributions to the Cartesian gradient.
2252 C
2253           ggg(1)=fac*xj
2254           ggg(2)=fac*yj
2255           ggg(3)=fac*zj
2256           do k=1,3
2257             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2258             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2259           enddo
2260 *
2261 * Loop over residues i+1 thru j-1.
2262 *
2263 cgrad          do k=i+1,j-1
2264 cgrad            do l=1,3
2265 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2266 cgrad            enddo
2267 cgrad          enddo
2268         enddo ! j
2269       enddo   ! i
2270 cgrad      do i=nnt,nct-1
2271 cgrad        do k=1,3
2272 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2273 cgrad        enddo
2274 cgrad        do j=i+1,nct-1
2275 cgrad          do k=1,3
2276 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2277 cgrad          enddo
2278 cgrad        enddo
2279 cgrad      enddo
2280       return
2281       end
2282 c------------------------------------------------------------------------------
2283       subroutine vec_and_deriv
2284       implicit real*8 (a-h,o-z)
2285       include 'DIMENSIONS'
2286 #ifdef MPI
2287       include 'mpif.h'
2288 #endif
2289       include 'COMMON.IOUNITS'
2290       include 'COMMON.GEO'
2291       include 'COMMON.VAR'
2292       include 'COMMON.LOCAL'
2293       include 'COMMON.CHAIN'
2294       include 'COMMON.VECTORS'
2295       include 'COMMON.SETUP'
2296       include 'COMMON.TIME1'
2297       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2298 C Compute the local reference systems. For reference system (i), the
2299 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2300 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2301 #ifdef PARVEC
2302       do i=ivec_start,ivec_end
2303 #else
2304       do i=1,nres-1
2305 #endif
2306           if (i.eq.nres-1) then
2307 C Case of the last full residue
2308 C Compute the Z-axis
2309             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2310             costh=dcos(pi-theta(nres))
2311             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2312             do k=1,3
2313               uz(k,i)=fac*uz(k,i)
2314             enddo
2315 C Compute the derivatives of uz
2316             uzder(1,1,1)= 0.0d0
2317             uzder(2,1,1)=-dc_norm(3,i-1)
2318             uzder(3,1,1)= dc_norm(2,i-1)
2319             uzder(1,2,1)= dc_norm(3,i-1)
2320             uzder(2,2,1)= 0.0d0
2321             uzder(3,2,1)=-dc_norm(1,i-1)
2322             uzder(1,3,1)=-dc_norm(2,i-1)
2323             uzder(2,3,1)= dc_norm(1,i-1)
2324             uzder(3,3,1)= 0.0d0
2325             uzder(1,1,2)= 0.0d0
2326             uzder(2,1,2)= dc_norm(3,i)
2327             uzder(3,1,2)=-dc_norm(2,i)
2328             uzder(1,2,2)=-dc_norm(3,i)
2329             uzder(2,2,2)= 0.0d0
2330             uzder(3,2,2)= dc_norm(1,i)
2331             uzder(1,3,2)= dc_norm(2,i)
2332             uzder(2,3,2)=-dc_norm(1,i)
2333             uzder(3,3,2)= 0.0d0
2334 C Compute the Y-axis
2335             facy=fac
2336             do k=1,3
2337               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2338             enddo
2339 C Compute the derivatives of uy
2340             do j=1,3
2341               do k=1,3
2342                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2343      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2344                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2345               enddo
2346               uyder(j,j,1)=uyder(j,j,1)-costh
2347               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2348             enddo
2349             do j=1,2
2350               do k=1,3
2351                 do l=1,3
2352                   uygrad(l,k,j,i)=uyder(l,k,j)
2353                   uzgrad(l,k,j,i)=uzder(l,k,j)
2354                 enddo
2355               enddo
2356             enddo
2357             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2358             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2359             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2360             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2361           else
2362 C Other residues
2363 C Compute the Z-axis
2364             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2365             costh=dcos(pi-theta(i+2))
2366             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2367             do k=1,3
2368               uz(k,i)=fac*uz(k,i)
2369             enddo
2370 C Compute the derivatives of uz
2371             uzder(1,1,1)= 0.0d0
2372             uzder(2,1,1)=-dc_norm(3,i+1)
2373             uzder(3,1,1)= dc_norm(2,i+1)
2374             uzder(1,2,1)= dc_norm(3,i+1)
2375             uzder(2,2,1)= 0.0d0
2376             uzder(3,2,1)=-dc_norm(1,i+1)
2377             uzder(1,3,1)=-dc_norm(2,i+1)
2378             uzder(2,3,1)= dc_norm(1,i+1)
2379             uzder(3,3,1)= 0.0d0
2380             uzder(1,1,2)= 0.0d0
2381             uzder(2,1,2)= dc_norm(3,i)
2382             uzder(3,1,2)=-dc_norm(2,i)
2383             uzder(1,2,2)=-dc_norm(3,i)
2384             uzder(2,2,2)= 0.0d0
2385             uzder(3,2,2)= dc_norm(1,i)
2386             uzder(1,3,2)= dc_norm(2,i)
2387             uzder(2,3,2)=-dc_norm(1,i)
2388             uzder(3,3,2)= 0.0d0
2389 C Compute the Y-axis
2390             facy=fac
2391             do k=1,3
2392               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2393             enddo
2394 C Compute the derivatives of uy
2395             do j=1,3
2396               do k=1,3
2397                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2398      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2399                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2400               enddo
2401               uyder(j,j,1)=uyder(j,j,1)-costh
2402               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2403             enddo
2404             do j=1,2
2405               do k=1,3
2406                 do l=1,3
2407                   uygrad(l,k,j,i)=uyder(l,k,j)
2408                   uzgrad(l,k,j,i)=uzder(l,k,j)
2409                 enddo
2410               enddo
2411             enddo
2412             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2413             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2414             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2415             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2416           endif
2417       enddo
2418       do i=1,nres-1
2419         vbld_inv_temp(1)=vbld_inv(i+1)
2420         if (i.lt.nres-1) then
2421           vbld_inv_temp(2)=vbld_inv(i+2)
2422           else
2423           vbld_inv_temp(2)=vbld_inv(i)
2424           endif
2425         do j=1,2
2426           do k=1,3
2427             do l=1,3
2428               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2429               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2430             enddo
2431           enddo
2432         enddo
2433       enddo
2434 #if defined(PARVEC) && defined(MPI)
2435       if (nfgtasks1.gt.1) then
2436         time00=MPI_Wtime()
2437 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2438 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2439 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2440         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2441      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2442      &   FG_COMM1,IERR)
2443         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2444      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2445      &   FG_COMM1,IERR)
2446         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2447      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2448      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2449         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2450      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2451      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2452         time_gather=time_gather+MPI_Wtime()-time00
2453       endif
2454 c      if (fg_rank.eq.0) then
2455 c        write (iout,*) "Arrays UY and UZ"
2456 c        do i=1,nres-1
2457 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2458 c     &     (uz(k,i),k=1,3)
2459 c        enddo
2460 c      endif
2461 #endif
2462       return
2463       end
2464 C-----------------------------------------------------------------------------
2465       subroutine check_vecgrad
2466       implicit real*8 (a-h,o-z)
2467       include 'DIMENSIONS'
2468       include 'COMMON.IOUNITS'
2469       include 'COMMON.GEO'
2470       include 'COMMON.VAR'
2471       include 'COMMON.LOCAL'
2472       include 'COMMON.CHAIN'
2473       include 'COMMON.VECTORS'
2474       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2475       dimension uyt(3,maxres),uzt(3,maxres)
2476       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2477       double precision delta /1.0d-7/
2478       call vec_and_deriv
2479 cd      do i=1,nres
2480 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2481 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2482 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2483 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2484 cd     &     (dc_norm(if90,i),if90=1,3)
2485 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2486 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2487 cd          write(iout,'(a)')
2488 cd      enddo
2489       do i=1,nres
2490         do j=1,2
2491           do k=1,3
2492             do l=1,3
2493               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2494               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2495             enddo
2496           enddo
2497         enddo
2498       enddo
2499       call vec_and_deriv
2500       do i=1,nres
2501         do j=1,3
2502           uyt(j,i)=uy(j,i)
2503           uzt(j,i)=uz(j,i)
2504         enddo
2505       enddo
2506       do i=1,nres
2507 cd        write (iout,*) 'i=',i
2508         do k=1,3
2509           erij(k)=dc_norm(k,i)
2510         enddo
2511         do j=1,3
2512           do k=1,3
2513             dc_norm(k,i)=erij(k)
2514           enddo
2515           dc_norm(j,i)=dc_norm(j,i)+delta
2516 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2517 c          do k=1,3
2518 c            dc_norm(k,i)=dc_norm(k,i)/fac
2519 c          enddo
2520 c          write (iout,*) (dc_norm(k,i),k=1,3)
2521 c          write (iout,*) (erij(k),k=1,3)
2522           call vec_and_deriv
2523           do k=1,3
2524             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2525             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2526             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2527             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2528           enddo
2529 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2530 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2531 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2532         enddo
2533         do k=1,3
2534           dc_norm(k,i)=erij(k)
2535         enddo
2536 cd        do k=1,3
2537 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2538 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2539 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2540 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2541 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2542 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2543 cd          write (iout,'(a)')
2544 cd        enddo
2545       enddo
2546       return
2547       end
2548 C--------------------------------------------------------------------------
2549       subroutine set_matrices
2550       implicit real*8 (a-h,o-z)
2551       include 'DIMENSIONS'
2552 #ifdef MPI
2553       include "mpif.h"
2554       include "COMMON.SETUP"
2555       integer IERR
2556       integer status(MPI_STATUS_SIZE)
2557 #endif
2558       include 'COMMON.IOUNITS'
2559       include 'COMMON.GEO'
2560       include 'COMMON.VAR'
2561       include 'COMMON.LOCAL'
2562       include 'COMMON.CHAIN'
2563       include 'COMMON.DERIV'
2564       include 'COMMON.INTERACT'
2565       include 'COMMON.CONTACTS'
2566       include 'COMMON.TORSION'
2567       include 'COMMON.VECTORS'
2568       include 'COMMON.FFIELD'
2569       double precision auxvec(2),auxmat(2,2)
2570 C
2571 C Compute the virtual-bond-torsional-angle dependent quantities needed
2572 C to calculate the el-loc multibody terms of various order.
2573 C
2574 #ifdef PARMAT
2575       do i=ivec_start+2,ivec_end+2
2576 #else
2577       do i=3,nres+1
2578 #endif
2579         if (i .lt. nres+1) then
2580           sin1=dsin(phi(i))
2581           cos1=dcos(phi(i))
2582           sintab(i-2)=sin1
2583           costab(i-2)=cos1
2584           obrot(1,i-2)=cos1
2585           obrot(2,i-2)=sin1
2586           sin2=dsin(2*phi(i))
2587           cos2=dcos(2*phi(i))
2588           sintab2(i-2)=sin2
2589           costab2(i-2)=cos2
2590           obrot2(1,i-2)=cos2
2591           obrot2(2,i-2)=sin2
2592           Ug(1,1,i-2)=-cos1
2593           Ug(1,2,i-2)=-sin1
2594           Ug(2,1,i-2)=-sin1
2595           Ug(2,2,i-2)= cos1
2596           Ug2(1,1,i-2)=-cos2
2597           Ug2(1,2,i-2)=-sin2
2598           Ug2(2,1,i-2)=-sin2
2599           Ug2(2,2,i-2)= cos2
2600         else
2601           costab(i-2)=1.0d0
2602           sintab(i-2)=0.0d0
2603           obrot(1,i-2)=1.0d0
2604           obrot(2,i-2)=0.0d0
2605           obrot2(1,i-2)=0.0d0
2606           obrot2(2,i-2)=0.0d0
2607           Ug(1,1,i-2)=1.0d0
2608           Ug(1,2,i-2)=0.0d0
2609           Ug(2,1,i-2)=0.0d0
2610           Ug(2,2,i-2)=1.0d0
2611           Ug2(1,1,i-2)=0.0d0
2612           Ug2(1,2,i-2)=0.0d0
2613           Ug2(2,1,i-2)=0.0d0
2614           Ug2(2,2,i-2)=0.0d0
2615         endif
2616         if (i .gt. 3 .and. i .lt. nres+1) then
2617           obrot_der(1,i-2)=-sin1
2618           obrot_der(2,i-2)= cos1
2619           Ugder(1,1,i-2)= sin1
2620           Ugder(1,2,i-2)=-cos1
2621           Ugder(2,1,i-2)=-cos1
2622           Ugder(2,2,i-2)=-sin1
2623           dwacos2=cos2+cos2
2624           dwasin2=sin2+sin2
2625           obrot2_der(1,i-2)=-dwasin2
2626           obrot2_der(2,i-2)= dwacos2
2627           Ug2der(1,1,i-2)= dwasin2
2628           Ug2der(1,2,i-2)=-dwacos2
2629           Ug2der(2,1,i-2)=-dwacos2
2630           Ug2der(2,2,i-2)=-dwasin2
2631         else
2632           obrot_der(1,i-2)=0.0d0
2633           obrot_der(2,i-2)=0.0d0
2634           Ugder(1,1,i-2)=0.0d0
2635           Ugder(1,2,i-2)=0.0d0
2636           Ugder(2,1,i-2)=0.0d0
2637           Ugder(2,2,i-2)=0.0d0
2638           obrot2_der(1,i-2)=0.0d0
2639           obrot2_der(2,i-2)=0.0d0
2640           Ug2der(1,1,i-2)=0.0d0
2641           Ug2der(1,2,i-2)=0.0d0
2642           Ug2der(2,1,i-2)=0.0d0
2643           Ug2der(2,2,i-2)=0.0d0
2644         endif
2645 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2646         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2647           iti = itortyp(itype(i-2))
2648         else
2649           iti=ntortyp+1
2650         endif
2651 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2652         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2653           iti1 = itortyp(itype(i-1))
2654         else
2655           iti1=ntortyp+1
2656         endif
2657 cd        write (iout,*) '*******i',i,' iti1',iti
2658 cd        write (iout,*) 'b1',b1(:,iti)
2659 cd        write (iout,*) 'b2',b2(:,iti)
2660 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2661 c        if (i .gt. iatel_s+2) then
2662         if (i .gt. nnt+2) then
2663           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2664           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2665           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2666      &    then
2667           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2668           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2669           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2670           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2671           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2672           endif
2673         else
2674           do k=1,2
2675             Ub2(k,i-2)=0.0d0
2676             Ctobr(k,i-2)=0.0d0
2677             Dtobr2(k,i-2)=0.0d0
2678             do l=1,2
2679               EUg(l,k,i-2)=0.0d0
2680               CUg(l,k,i-2)=0.0d0
2681               DUg(l,k,i-2)=0.0d0
2682               DtUg2(l,k,i-2)=0.0d0
2683             enddo
2684           enddo
2685         endif
2686         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2687         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2688         do k=1,2
2689           muder(k,i-2)=Ub2der(k,i-2)
2690         enddo
2691 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2692         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2693           iti1 = itortyp(itype(i-1))
2694         else
2695           iti1=ntortyp+1
2696         endif
2697         do k=1,2
2698           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2699         enddo
2700 cd        write (iout,*) 'mu ',mu(:,i-2)
2701 cd        write (iout,*) 'mu1',mu1(:,i-2)
2702 cd        write (iout,*) 'mu2',mu2(:,i-2)
2703         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2704      &  then
2705         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2706         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2707         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2708         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2709         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2710 C Vectors and matrices dependent on a single virtual-bond dihedral.
2711         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2712         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2713         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2714         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2715         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2716         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2717         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2718         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2719         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2720         endif
2721       enddo
2722 C Matrices dependent on two consecutive virtual-bond dihedrals.
2723 C The order of matrices is from left to right.
2724       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2725      &then
2726 c      do i=max0(ivec_start,2),ivec_end
2727       do i=2,nres-1
2728         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2729         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2730         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2731         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2732         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2733         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2734         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2735         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2736       enddo
2737       endif
2738 #if defined(MPI) && defined(PARMAT)
2739 #ifdef DEBUG
2740 c      if (fg_rank.eq.0) then
2741         write (iout,*) "Arrays UG and UGDER before GATHER"
2742         do i=1,nres-1
2743           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2744      &     ((ug(l,k,i),l=1,2),k=1,2),
2745      &     ((ugder(l,k,i),l=1,2),k=1,2)
2746         enddo
2747         write (iout,*) "Arrays UG2 and UG2DER"
2748         do i=1,nres-1
2749           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2750      &     ((ug2(l,k,i),l=1,2),k=1,2),
2751      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2752         enddo
2753         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2754         do i=1,nres-1
2755           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2756      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2757      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2758         enddo
2759         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2760         do i=1,nres-1
2761           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2762      &     costab(i),sintab(i),costab2(i),sintab2(i)
2763         enddo
2764         write (iout,*) "Array MUDER"
2765         do i=1,nres-1
2766           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2767         enddo
2768 c      endif
2769 #endif
2770       if (nfgtasks.gt.1) then
2771         time00=MPI_Wtime()
2772 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2773 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2774 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2775 #ifdef MATGATHER
2776         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2777      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2778      &   FG_COMM1,IERR)
2779         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2780      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2781      &   FG_COMM1,IERR)
2782         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2783      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2784      &   FG_COMM1,IERR)
2785         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2786      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2787      &   FG_COMM1,IERR)
2788         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2789      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2790      &   FG_COMM1,IERR)
2791         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2792      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2793      &   FG_COMM1,IERR)
2794         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2795      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2796      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2797         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2798      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2799      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2800         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2801      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2802      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2803         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2804      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2805      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2806         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2807      &  then
2808         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2809      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2810      &   FG_COMM1,IERR)
2811         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2812      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2813      &   FG_COMM1,IERR)
2814         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2815      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2816      &   FG_COMM1,IERR)
2817        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2818      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2819      &   FG_COMM1,IERR)
2820         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2821      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2822      &   FG_COMM1,IERR)
2823         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2824      &   ivec_count(fg_rank1),
2825      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2826      &   FG_COMM1,IERR)
2827         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2828      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2829      &   FG_COMM1,IERR)
2830         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2831      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2832      &   FG_COMM1,IERR)
2833         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2834      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2835      &   FG_COMM1,IERR)
2836         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2837      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2838      &   FG_COMM1,IERR)
2839         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2840      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2841      &   FG_COMM1,IERR)
2842         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2843      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2844      &   FG_COMM1,IERR)
2845         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2846      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2847      &   FG_COMM1,IERR)
2848         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2849      &   ivec_count(fg_rank1),
2850      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2851      &   FG_COMM1,IERR)
2852         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2853      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2854      &   FG_COMM1,IERR)
2855        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2856      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2857      &   FG_COMM1,IERR)
2858         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2859      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2860      &   FG_COMM1,IERR)
2861        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2862      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2863      &   FG_COMM1,IERR)
2864         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2865      &   ivec_count(fg_rank1),
2866      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2867      &   FG_COMM1,IERR)
2868         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2869      &   ivec_count(fg_rank1),
2870      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2871      &   FG_COMM1,IERR)
2872         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2873      &   ivec_count(fg_rank1),
2874      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2875      &   MPI_MAT2,FG_COMM1,IERR)
2876         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2877      &   ivec_count(fg_rank1),
2878      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2879      &   MPI_MAT2,FG_COMM1,IERR)
2880         endif
2881 #else
2882 c Passes matrix info through the ring
2883       isend=fg_rank1
2884       irecv=fg_rank1-1
2885       if (irecv.lt.0) irecv=nfgtasks1-1
2886       iprev=irecv
2887       inext=fg_rank1+1
2888       if (inext.ge.nfgtasks1) inext=0
2889       do i=1,nfgtasks1-1
2890 c        write (iout,*) "isend",isend," irecv",irecv
2891 c        call flush(iout)
2892         lensend=lentyp(isend)
2893         lenrecv=lentyp(irecv)
2894 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2895 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2896 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2897 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2898 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2899 c        write (iout,*) "Gather ROTAT1"
2900 c        call flush(iout)
2901 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2902 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2903 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2904 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2905 c        write (iout,*) "Gather ROTAT2"
2906 c        call flush(iout)
2907         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2908      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2909      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2910      &   iprev,4400+irecv,FG_COMM,status,IERR)
2911 c        write (iout,*) "Gather ROTAT_OLD"
2912 c        call flush(iout)
2913         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2914      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2915      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2916      &   iprev,5500+irecv,FG_COMM,status,IERR)
2917 c        write (iout,*) "Gather PRECOMP11"
2918 c        call flush(iout)
2919         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2920      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2921      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2922      &   iprev,6600+irecv,FG_COMM,status,IERR)
2923 c        write (iout,*) "Gather PRECOMP12"
2924 c        call flush(iout)
2925         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2926      &  then
2927         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2928      &   MPI_ROTAT2(lensend),inext,7700+isend,
2929      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2930      &   iprev,7700+irecv,FG_COMM,status,IERR)
2931 c        write (iout,*) "Gather PRECOMP21"
2932 c        call flush(iout)
2933         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2934      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2935      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2936      &   iprev,8800+irecv,FG_COMM,status,IERR)
2937 c        write (iout,*) "Gather PRECOMP22"
2938 c        call flush(iout)
2939         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2940      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2941      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2942      &   MPI_PRECOMP23(lenrecv),
2943      &   iprev,9900+irecv,FG_COMM,status,IERR)
2944 c        write (iout,*) "Gather PRECOMP23"
2945 c        call flush(iout)
2946         endif
2947         isend=irecv
2948         irecv=irecv-1
2949         if (irecv.lt.0) irecv=nfgtasks1-1
2950       enddo
2951 #endif
2952         time_gather=time_gather+MPI_Wtime()-time00
2953       endif
2954 #ifdef DEBUG
2955 c      if (fg_rank.eq.0) then
2956         write (iout,*) "Arrays UG and UGDER"
2957         do i=1,nres-1
2958           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2959      &     ((ug(l,k,i),l=1,2),k=1,2),
2960      &     ((ugder(l,k,i),l=1,2),k=1,2)
2961         enddo
2962         write (iout,*) "Arrays UG2 and UG2DER"
2963         do i=1,nres-1
2964           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2965      &     ((ug2(l,k,i),l=1,2),k=1,2),
2966      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2967         enddo
2968         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2969         do i=1,nres-1
2970           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2971      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2972      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2973         enddo
2974         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2975         do i=1,nres-1
2976           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2977      &     costab(i),sintab(i),costab2(i),sintab2(i)
2978         enddo
2979         write (iout,*) "Array MUDER"
2980         do i=1,nres-1
2981           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2982         enddo
2983 c      endif
2984 #endif
2985 #endif
2986 cd      do i=1,nres
2987 cd        iti = itortyp(itype(i))
2988 cd        write (iout,*) i
2989 cd        do j=1,2
2990 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2991 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2992 cd        enddo
2993 cd      enddo
2994       return
2995       end
2996 C--------------------------------------------------------------------------
2997       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2998 C
2999 C This subroutine calculates the average interaction energy and its gradient
3000 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3001 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3002 C The potential depends both on the distance of peptide-group centers and on
3003 C the orientation of the CA-CA virtual bonds.
3004 C
3005       implicit real*8 (a-h,o-z)
3006 #ifdef MPI
3007       include 'mpif.h'
3008 #endif
3009       include 'DIMENSIONS'
3010       include 'COMMON.CONTROL'
3011       include 'COMMON.SETUP'
3012       include 'COMMON.IOUNITS'
3013       include 'COMMON.GEO'
3014       include 'COMMON.VAR'
3015       include 'COMMON.LOCAL'
3016       include 'COMMON.CHAIN'
3017       include 'COMMON.DERIV'
3018       include 'COMMON.INTERACT'
3019       include 'COMMON.CONTACTS'
3020       include 'COMMON.TORSION'
3021       include 'COMMON.VECTORS'
3022       include 'COMMON.FFIELD'
3023       include 'COMMON.TIME1'
3024       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3025      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3026       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3027      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3028       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3029      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3030      &    num_conti,j1,j2
3031 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3032 #ifdef MOMENT
3033       double precision scal_el /1.0d0/
3034 #else
3035       double precision scal_el /0.5d0/
3036 #endif
3037 C 12/13/98
3038 C 13-go grudnia roku pamietnego...
3039       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3040      &                   0.0d0,1.0d0,0.0d0,
3041      &                   0.0d0,0.0d0,1.0d0/
3042 cd      write(iout,*) 'In EELEC'
3043 cd      do i=1,nloctyp
3044 cd        write(iout,*) 'Type',i
3045 cd        write(iout,*) 'B1',B1(:,i)
3046 cd        write(iout,*) 'B2',B2(:,i)
3047 cd        write(iout,*) 'CC',CC(:,:,i)
3048 cd        write(iout,*) 'DD',DD(:,:,i)
3049 cd        write(iout,*) 'EE',EE(:,:,i)
3050 cd      enddo
3051 cd      call check_vecgrad
3052 cd      stop
3053       if (icheckgrad.eq.1) then
3054         do i=1,nres-1
3055           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3056           do k=1,3
3057             dc_norm(k,i)=dc(k,i)*fac
3058           enddo
3059 c          write (iout,*) 'i',i,' fac',fac
3060         enddo
3061       endif
3062       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3063      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3064      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3065 c        call vec_and_deriv
3066 #ifdef TIMING
3067         time01=MPI_Wtime()
3068 #endif
3069         call set_matrices
3070 #ifdef TIMING
3071         time_mat=time_mat+MPI_Wtime()-time01
3072 #endif
3073       endif
3074 cd      do i=1,nres-1
3075 cd        write (iout,*) 'i=',i
3076 cd        do k=1,3
3077 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3078 cd        enddo
3079 cd        do k=1,3
3080 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3081 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3082 cd        enddo
3083 cd      enddo
3084       t_eelecij=0.0d0
3085       ees=0.0D0
3086       evdw1=0.0D0
3087       eel_loc=0.0d0
3088       eello_turn3=0.0d0
3089       eello_turn4=0.0d0
3090       ind=0
3091       do i=1,nres
3092         num_cont_hb(i)=0
3093       enddo
3094 cd      print '(a)','Enter EELEC'
3095 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3096       do i=1,nres
3097         gel_loc_loc(i)=0.0d0
3098         gcorr_loc(i)=0.0d0
3099       enddo
3100 c
3101 c
3102 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3103 C
3104 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3105 C
3106       do i=iturn3_start,iturn3_end
3107         dxi=dc(1,i)
3108         dyi=dc(2,i)
3109         dzi=dc(3,i)
3110         dx_normi=dc_norm(1,i)
3111         dy_normi=dc_norm(2,i)
3112         dz_normi=dc_norm(3,i)
3113         xmedi=c(1,i)+0.5d0*dxi
3114         ymedi=c(2,i)+0.5d0*dyi
3115         zmedi=c(3,i)+0.5d0*dzi
3116         num_conti=0
3117         call eelecij(i,i+2,ees,evdw1,eel_loc)
3118         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3119         num_cont_hb(i)=num_conti
3120       enddo
3121       do i=iturn4_start,iturn4_end
3122         dxi=dc(1,i)
3123         dyi=dc(2,i)
3124         dzi=dc(3,i)
3125         dx_normi=dc_norm(1,i)
3126         dy_normi=dc_norm(2,i)
3127         dz_normi=dc_norm(3,i)
3128         xmedi=c(1,i)+0.5d0*dxi
3129         ymedi=c(2,i)+0.5d0*dyi
3130         zmedi=c(3,i)+0.5d0*dzi
3131         num_conti=num_cont_hb(i)
3132         call eelecij(i,i+3,ees,evdw1,eel_loc)
3133         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3134         num_cont_hb(i)=num_conti
3135       enddo   ! i
3136 c
3137 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3138 c
3139       do i=iatel_s,iatel_e
3140         dxi=dc(1,i)
3141         dyi=dc(2,i)
3142         dzi=dc(3,i)
3143         dx_normi=dc_norm(1,i)
3144         dy_normi=dc_norm(2,i)
3145         dz_normi=dc_norm(3,i)
3146         xmedi=c(1,i)+0.5d0*dxi
3147         ymedi=c(2,i)+0.5d0*dyi
3148         zmedi=c(3,i)+0.5d0*dzi
3149 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3150         num_conti=num_cont_hb(i)
3151         do j=ielstart(i),ielend(i)
3152           call eelecij(i,j,ees,evdw1,eel_loc)
3153         enddo ! j
3154         num_cont_hb(i)=num_conti
3155       enddo   ! i
3156 c      write (iout,*) "Number of loop steps in EELEC:",ind
3157 cd      do i=1,nres
3158 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3159 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3160 cd      enddo
3161 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3162 ccc      eel_loc=eel_loc+eello_turn3
3163 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3164       return
3165       end
3166 C-------------------------------------------------------------------------------
3167       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3168       implicit real*8 (a-h,o-z)
3169       include 'DIMENSIONS'
3170 #ifdef MPI
3171       include "mpif.h"
3172 #endif
3173       include 'COMMON.CONTROL'
3174       include 'COMMON.IOUNITS'
3175       include 'COMMON.GEO'
3176       include 'COMMON.VAR'
3177       include 'COMMON.LOCAL'
3178       include 'COMMON.CHAIN'
3179       include 'COMMON.DERIV'
3180       include 'COMMON.INTERACT'
3181       include 'COMMON.CONTACTS'
3182       include 'COMMON.TORSION'
3183       include 'COMMON.VECTORS'
3184       include 'COMMON.FFIELD'
3185       include 'COMMON.TIME1'
3186       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3187      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3188       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3189      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3190       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3191      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3192      &    num_conti,j1,j2
3193 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3194 #ifdef MOMENT
3195       double precision scal_el /1.0d0/
3196 #else
3197       double precision scal_el /0.5d0/
3198 #endif
3199 C 12/13/98
3200 C 13-go grudnia roku pamietnego...
3201       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3202      &                   0.0d0,1.0d0,0.0d0,
3203      &                   0.0d0,0.0d0,1.0d0/
3204 c          time00=MPI_Wtime()
3205 cd      write (iout,*) "eelecij",i,j
3206 c          ind=ind+1
3207           iteli=itel(i)
3208           itelj=itel(j)
3209           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3210           aaa=app(iteli,itelj)
3211           bbb=bpp(iteli,itelj)
3212           ael6i=ael6(iteli,itelj)
3213           ael3i=ael3(iteli,itelj)
3214           dxj=dc(1,j)
3215           dyj=dc(2,j)
3216           dzj=dc(3,j)
3217           dx_normj=dc_norm(1,j)
3218           dy_normj=dc_norm(2,j)
3219           dz_normj=dc_norm(3,j)
3220           xj=c(1,j)+0.5D0*dxj-xmedi
3221           yj=c(2,j)+0.5D0*dyj-ymedi
3222           zj=c(3,j)+0.5D0*dzj-zmedi
3223           rij=xj*xj+yj*yj+zj*zj
3224           rrmij=1.0D0/rij
3225           rij=dsqrt(rij)
3226           rmij=1.0D0/rij
3227           r3ij=rrmij*rmij
3228           r6ij=r3ij*r3ij
3229           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3230           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3231           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3232           fac=cosa-3.0D0*cosb*cosg
3233           ev1=aaa*r6ij*r6ij
3234 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3235           if (j.eq.i+2) ev1=scal_el*ev1
3236           ev2=bbb*r6ij
3237           fac3=ael6i*r6ij
3238           fac4=ael3i*r3ij
3239           evdwij=ev1+ev2
3240           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3241           el2=fac4*fac
3242           eesij=el1+el2
3243 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3244           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3245           ees=ees+eesij
3246           evdw1=evdw1+evdwij
3247 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3248 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3249 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3250 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3251
3252           if (energy_dec) then
3253               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3254               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3255           endif
3256
3257 C
3258 C Calculate contributions to the Cartesian gradient.
3259 C
3260 #ifdef SPLITELE
3261           facvdw=-6*rrmij*(ev1+evdwij)
3262           facel=-3*rrmij*(el1+eesij)
3263           fac1=fac
3264           erij(1)=xj*rmij
3265           erij(2)=yj*rmij
3266           erij(3)=zj*rmij
3267 *
3268 * Radial derivatives. First process both termini of the fragment (i,j)
3269 *
3270           ggg(1)=facel*xj
3271           ggg(2)=facel*yj
3272           ggg(3)=facel*zj
3273 c          do k=1,3
3274 c            ghalf=0.5D0*ggg(k)
3275 c            gelc(k,i)=gelc(k,i)+ghalf
3276 c            gelc(k,j)=gelc(k,j)+ghalf
3277 c          enddo
3278 c 9/28/08 AL Gradient compotents will be summed only at the end
3279           do k=1,3
3280             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3281             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3282           enddo
3283 *
3284 * Loop over residues i+1 thru j-1.
3285 *
3286 cgrad          do k=i+1,j-1
3287 cgrad            do l=1,3
3288 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3289 cgrad            enddo
3290 cgrad          enddo
3291           ggg(1)=facvdw*xj
3292           ggg(2)=facvdw*yj
3293           ggg(3)=facvdw*zj
3294 c          do k=1,3
3295 c            ghalf=0.5D0*ggg(k)
3296 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3297 c            gvdwpp(k,j)=gvdwpp(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             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3302             gvdwpp(k,i)=gvdwpp(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              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3310 cgrad            enddo
3311 cgrad          enddo
3312 #else
3313           facvdw=ev1+evdwij
3314           facel=el1+eesij
3315           fac1=fac
3316           fac=-3*rrmij*(facvdw+facvdw+facel)
3317           erij(1)=xj*rmij
3318           erij(2)=yj*rmij
3319           erij(3)=zj*rmij
3320 *
3321 * Radial derivatives. First process both termini of the fragment (i,j)
3322 *
3323           ggg(1)=fac*xj
3324           ggg(2)=fac*yj
3325           ggg(3)=fac*zj
3326 c          do k=1,3
3327 c            ghalf=0.5D0*ggg(k)
3328 c            gelc(k,i)=gelc(k,i)+ghalf
3329 c            gelc(k,j)=gelc(k,j)+ghalf
3330 c          enddo
3331 c 9/28/08 AL Gradient compotents will be summed only at the end
3332           do k=1,3
3333             gelc_long(k,j)=gelc(k,j)+ggg(k)
3334             gelc_long(k,i)=gelc(k,i)-ggg(k)
3335           enddo
3336 *
3337 * Loop over residues i+1 thru j-1.
3338 *
3339 cgrad          do k=i+1,j-1
3340 cgrad            do l=1,3
3341 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3342 cgrad            enddo
3343 cgrad          enddo
3344 c 9/28/08 AL Gradient compotents will be summed only at the end
3345           ggg(1)=facvdw*xj
3346           ggg(2)=facvdw*yj
3347           ggg(3)=facvdw*zj
3348           do k=1,3
3349             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3350             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3351           enddo
3352 #endif
3353 *
3354 * Angular part
3355 *
3356           ecosa=2.0D0*fac3*fac1+fac4
3357           fac4=-3.0D0*fac4
3358           fac3=-6.0D0*fac3
3359           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3360           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3361           do k=1,3
3362             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3363             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3364           enddo
3365 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3366 cd   &          (dcosg(k),k=1,3)
3367           do k=1,3
3368             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3369           enddo
3370 c          do k=1,3
3371 c            ghalf=0.5D0*ggg(k)
3372 c            gelc(k,i)=gelc(k,i)+ghalf
3373 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3374 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3375 c            gelc(k,j)=gelc(k,j)+ghalf
3376 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3377 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3378 c          enddo
3379 cgrad          do k=i+1,j-1
3380 cgrad            do l=1,3
3381 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3382 cgrad            enddo
3383 cgrad          enddo
3384           do k=1,3
3385             gelc(k,i)=gelc(k,i)
3386      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3387      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3388             gelc(k,j)=gelc(k,j)
3389      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3390      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3391             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3392             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3393           enddo
3394           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3395      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3396      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3397 C
3398 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3399 C   energy of a peptide unit is assumed in the form of a second-order
3400 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3401 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3402 C   are computed for EVERY pair of non-contiguous peptide groups.
3403 C
3404           if (j.lt.nres-1) then
3405             j1=j+1
3406             j2=j-1
3407           else
3408             j1=j-1
3409             j2=j-2
3410           endif
3411           kkk=0
3412           do k=1,2
3413             do l=1,2
3414               kkk=kkk+1
3415               muij(kkk)=mu(k,i)*mu(l,j)
3416             enddo
3417           enddo
3418 cd         write (iout,*) 'EELEC: i',i,' j',j
3419 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3420 cd          write(iout,*) 'muij',muij
3421           ury=scalar(uy(1,i),erij)
3422           urz=scalar(uz(1,i),erij)
3423           vry=scalar(uy(1,j),erij)
3424           vrz=scalar(uz(1,j),erij)
3425           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3426           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3427           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3428           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3429           fac=dsqrt(-ael6i)*r3ij
3430           a22=a22*fac
3431           a23=a23*fac
3432           a32=a32*fac
3433           a33=a33*fac
3434 cd          write (iout,'(4i5,4f10.5)')
3435 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3436 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3437 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3438 cd     &      uy(:,j),uz(:,j)
3439 cd          write (iout,'(4f10.5)')
3440 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3441 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3442 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3443 cd           write (iout,'(9f10.5/)')
3444 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3445 C Derivatives of the elements of A in virtual-bond vectors
3446           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3447           do k=1,3
3448             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3449             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3450             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3451             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3452             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3453             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3454             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3455             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3456             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3457             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3458             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3459             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3460           enddo
3461 C Compute radial contributions to the gradient
3462           facr=-3.0d0*rrmij
3463           a22der=a22*facr
3464           a23der=a23*facr
3465           a32der=a32*facr
3466           a33der=a33*facr
3467           agg(1,1)=a22der*xj
3468           agg(2,1)=a22der*yj
3469           agg(3,1)=a22der*zj
3470           agg(1,2)=a23der*xj
3471           agg(2,2)=a23der*yj
3472           agg(3,2)=a23der*zj
3473           agg(1,3)=a32der*xj
3474           agg(2,3)=a32der*yj
3475           agg(3,3)=a32der*zj
3476           agg(1,4)=a33der*xj
3477           agg(2,4)=a33der*yj
3478           agg(3,4)=a33der*zj
3479 C Add the contributions coming from er
3480           fac3=-3.0d0*fac
3481           do k=1,3
3482             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3483             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3484             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3485             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3486           enddo
3487           do k=1,3
3488 C Derivatives in DC(i)
3489 cgrad            ghalf1=0.5d0*agg(k,1)
3490 cgrad            ghalf2=0.5d0*agg(k,2)
3491 cgrad            ghalf3=0.5d0*agg(k,3)
3492 cgrad            ghalf4=0.5d0*agg(k,4)
3493             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3494      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3495             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3496      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3497             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3498      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3499             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3500      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3501 C Derivatives in DC(i+1)
3502             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3503      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3504             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3505      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3506             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3507      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3508             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3509      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3510 C Derivatives in DC(j)
3511             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3512      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3513             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3514      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3515             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3516      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3517             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3518      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3519 C Derivatives in DC(j+1) or DC(nres-1)
3520             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3521      &      -3.0d0*vryg(k,3)*ury)
3522             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3523      &      -3.0d0*vrzg(k,3)*ury)
3524             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3525      &      -3.0d0*vryg(k,3)*urz)
3526             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3527      &      -3.0d0*vrzg(k,3)*urz)
3528 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3529 cgrad              do l=1,4
3530 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3531 cgrad              enddo
3532 cgrad            endif
3533           enddo
3534           acipa(1,1)=a22
3535           acipa(1,2)=a23
3536           acipa(2,1)=a32
3537           acipa(2,2)=a33
3538           a22=-a22
3539           a23=-a23
3540           do l=1,2
3541             do k=1,3
3542               agg(k,l)=-agg(k,l)
3543               aggi(k,l)=-aggi(k,l)
3544               aggi1(k,l)=-aggi1(k,l)
3545               aggj(k,l)=-aggj(k,l)
3546               aggj1(k,l)=-aggj1(k,l)
3547             enddo
3548           enddo
3549           if (j.lt.nres-1) then
3550             a22=-a22
3551             a32=-a32
3552             do l=1,3,2
3553               do k=1,3
3554                 agg(k,l)=-agg(k,l)
3555                 aggi(k,l)=-aggi(k,l)
3556                 aggi1(k,l)=-aggi1(k,l)
3557                 aggj(k,l)=-aggj(k,l)
3558                 aggj1(k,l)=-aggj1(k,l)
3559               enddo
3560             enddo
3561           else
3562             a22=-a22
3563             a23=-a23
3564             a32=-a32
3565             a33=-a33
3566             do l=1,4
3567               do k=1,3
3568                 agg(k,l)=-agg(k,l)
3569                 aggi(k,l)=-aggi(k,l)
3570                 aggi1(k,l)=-aggi1(k,l)
3571                 aggj(k,l)=-aggj(k,l)
3572                 aggj1(k,l)=-aggj1(k,l)
3573               enddo
3574             enddo
3575           endif
3576           ENDIF ! WCORR
3577           IF (wel_loc.gt.0.0d0) THEN
3578 C Contribution to the local-electrostatic energy coming from the i-j pair
3579           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3580      &     +a33*muij(4)
3581 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3582
3583           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3584      &            'eelloc',i,j,eel_loc_ij
3585
3586           eel_loc=eel_loc+eel_loc_ij
3587 C Partial derivatives in virtual-bond dihedral angles gamma
3588           if (i.gt.1)
3589      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3590      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3591      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3592           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3593      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3594      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3595 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3596           do l=1,3
3597             ggg(l)=agg(l,1)*muij(1)+
3598      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3599             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3600             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3601 cgrad            ghalf=0.5d0*ggg(l)
3602 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3603 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3604           enddo
3605 cgrad          do k=i+1,j2
3606 cgrad            do l=1,3
3607 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3608 cgrad            enddo
3609 cgrad          enddo
3610 C Remaining derivatives of eello
3611           do l=1,3
3612             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3613      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3614             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3615      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3616             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3617      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3618             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3619      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3620           enddo
3621           ENDIF
3622 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3623 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3624           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3625      &       .and. num_conti.le.maxconts) then
3626 c            write (iout,*) i,j," entered corr"
3627 C
3628 C Calculate the contact function. The ith column of the array JCONT will
3629 C contain the numbers of atoms that make contacts with the atom I (of numbers
3630 C greater than I). The arrays FACONT and GACONT will contain the values of
3631 C the contact function and its derivative.
3632 c           r0ij=1.02D0*rpp(iteli,itelj)
3633 c           r0ij=1.11D0*rpp(iteli,itelj)
3634             r0ij=2.20D0*rpp(iteli,itelj)
3635 c           r0ij=1.55D0*rpp(iteli,itelj)
3636             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3637             if (fcont.gt.0.0D0) then
3638               num_conti=num_conti+1
3639               if (num_conti.gt.maxconts) then
3640                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3641      &                         ' will skip next contacts for this conf.'
3642               else
3643                 jcont_hb(num_conti,i)=j
3644 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3645 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3646                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3647      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3648 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3649 C  terms.
3650                 d_cont(num_conti,i)=rij
3651 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3652 C     --- Electrostatic-interaction matrix ---
3653                 a_chuj(1,1,num_conti,i)=a22
3654                 a_chuj(1,2,num_conti,i)=a23
3655                 a_chuj(2,1,num_conti,i)=a32
3656                 a_chuj(2,2,num_conti,i)=a33
3657 C     --- Gradient of rij
3658                 do kkk=1,3
3659                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3660                 enddo
3661                 kkll=0
3662                 do k=1,2
3663                   do l=1,2
3664                     kkll=kkll+1
3665                     do m=1,3
3666                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3667                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3668                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3669                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3670                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3671                     enddo
3672                   enddo
3673                 enddo
3674                 ENDIF
3675                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3676 C Calculate contact energies
3677                 cosa4=4.0D0*cosa
3678                 wij=cosa-3.0D0*cosb*cosg
3679                 cosbg1=cosb+cosg
3680                 cosbg2=cosb-cosg
3681 c               fac3=dsqrt(-ael6i)/r0ij**3
3682                 fac3=dsqrt(-ael6i)*r3ij
3683 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3684                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3685                 if (ees0tmp.gt.0) then
3686                   ees0pij=dsqrt(ees0tmp)
3687                 else
3688                   ees0pij=0
3689                 endif
3690 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3691                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3692                 if (ees0tmp.gt.0) then
3693                   ees0mij=dsqrt(ees0tmp)
3694                 else
3695                   ees0mij=0
3696                 endif
3697 c               ees0mij=0.0D0
3698                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3699                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3700 C Diagnostics. Comment out or remove after debugging!
3701 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3702 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3703 c               ees0m(num_conti,i)=0.0D0
3704 C End diagnostics.
3705 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3706 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3707 C Angular derivatives of the contact function
3708                 ees0pij1=fac3/ees0pij
3709                 ees0mij1=fac3/ees0mij
3710                 fac3p=-3.0D0*fac3*rrmij
3711                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3712                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3713 c               ees0mij1=0.0D0
3714                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3715                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3716                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3717                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3718                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3719                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3720                 ecosap=ecosa1+ecosa2
3721                 ecosbp=ecosb1+ecosb2
3722                 ecosgp=ecosg1+ecosg2
3723                 ecosam=ecosa1-ecosa2
3724                 ecosbm=ecosb1-ecosb2
3725                 ecosgm=ecosg1-ecosg2
3726 C Diagnostics
3727 c               ecosap=ecosa1
3728 c               ecosbp=ecosb1
3729 c               ecosgp=ecosg1
3730 c               ecosam=0.0D0
3731 c               ecosbm=0.0D0
3732 c               ecosgm=0.0D0
3733 C End diagnostics
3734                 facont_hb(num_conti,i)=fcont
3735                 fprimcont=fprimcont/rij
3736 cd              facont_hb(num_conti,i)=1.0D0
3737 C Following line is for diagnostics.
3738 cd              fprimcont=0.0D0
3739                 do k=1,3
3740                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3741                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3742                 enddo
3743                 do k=1,3
3744                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3745                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3746                 enddo
3747                 gggp(1)=gggp(1)+ees0pijp*xj
3748                 gggp(2)=gggp(2)+ees0pijp*yj
3749                 gggp(3)=gggp(3)+ees0pijp*zj
3750                 gggm(1)=gggm(1)+ees0mijp*xj
3751                 gggm(2)=gggm(2)+ees0mijp*yj
3752                 gggm(3)=gggm(3)+ees0mijp*zj
3753 C Derivatives due to the contact function
3754                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3755                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3756                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3757                 do k=1,3
3758 c
3759 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3760 c          following the change of gradient-summation algorithm.
3761 c
3762 cgrad                  ghalfp=0.5D0*gggp(k)
3763 cgrad                  ghalfm=0.5D0*gggm(k)
3764                   gacontp_hb1(k,num_conti,i)=!ghalfp
3765      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3766      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3767                   gacontp_hb2(k,num_conti,i)=!ghalfp
3768      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3769      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3770                   gacontp_hb3(k,num_conti,i)=gggp(k)
3771                   gacontm_hb1(k,num_conti,i)=!ghalfm
3772      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3773      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3774                   gacontm_hb2(k,num_conti,i)=!ghalfm
3775      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3776      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3777                   gacontm_hb3(k,num_conti,i)=gggm(k)
3778                 enddo
3779 C Diagnostics. Comment out or remove after debugging!
3780 cdiag           do k=1,3
3781 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3782 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3783 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3784 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3785 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3786 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3787 cdiag           enddo
3788               ENDIF ! wcorr
3789               endif  ! num_conti.le.maxconts
3790             endif  ! fcont.gt.0
3791           endif    ! j.gt.i+1
3792           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3793             do k=1,4
3794               do l=1,3
3795                 ghalf=0.5d0*agg(l,k)
3796                 aggi(l,k)=aggi(l,k)+ghalf
3797                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3798                 aggj(l,k)=aggj(l,k)+ghalf
3799               enddo
3800             enddo
3801             if (j.eq.nres-1 .and. i.lt.j-2) then
3802               do k=1,4
3803                 do l=1,3
3804                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3805                 enddo
3806               enddo
3807             endif
3808           endif
3809 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3810       return
3811       end
3812 C-----------------------------------------------------------------------------
3813       subroutine eturn3(i,eello_turn3)
3814 C Third- and fourth-order contributions from turns
3815       implicit real*8 (a-h,o-z)
3816       include 'DIMENSIONS'
3817       include 'COMMON.IOUNITS'
3818       include 'COMMON.GEO'
3819       include 'COMMON.VAR'
3820       include 'COMMON.LOCAL'
3821       include 'COMMON.CHAIN'
3822       include 'COMMON.DERIV'
3823       include 'COMMON.INTERACT'
3824       include 'COMMON.CONTACTS'
3825       include 'COMMON.TORSION'
3826       include 'COMMON.VECTORS'
3827       include 'COMMON.FFIELD'
3828       include 'COMMON.CONTROL'
3829       dimension ggg(3)
3830       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3831      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3832      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3833       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3834      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3835       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3836      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3837      &    num_conti,j1,j2
3838       j=i+2
3839 c      write (iout,*) "eturn3",i,j,j1,j2
3840       a_temp(1,1)=a22
3841       a_temp(1,2)=a23
3842       a_temp(2,1)=a32
3843       a_temp(2,2)=a33
3844 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3845 C
3846 C               Third-order contributions
3847 C
3848 C                 (i+2)o----(i+3)
3849 C                      | |
3850 C                      | |
3851 C                 (i+1)o----i
3852 C
3853 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3854 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3855         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3856         call transpose2(auxmat(1,1),auxmat1(1,1))
3857         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3858         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3859         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3860      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3861 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3862 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3863 cd     &    ' eello_turn3_num',4*eello_turn3_num
3864 C Derivatives in gamma(i)
3865         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3866         call transpose2(auxmat2(1,1),auxmat3(1,1))
3867         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3868         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3869 C Derivatives in gamma(i+1)
3870         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3871         call transpose2(auxmat2(1,1),auxmat3(1,1))
3872         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3873         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3874      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3875 C Cartesian derivatives
3876         do l=1,3
3877 c            ghalf1=0.5d0*agg(l,1)
3878 c            ghalf2=0.5d0*agg(l,2)
3879 c            ghalf3=0.5d0*agg(l,3)
3880 c            ghalf4=0.5d0*agg(l,4)
3881           a_temp(1,1)=aggi(l,1)!+ghalf1
3882           a_temp(1,2)=aggi(l,2)!+ghalf2
3883           a_temp(2,1)=aggi(l,3)!+ghalf3
3884           a_temp(2,2)=aggi(l,4)!+ghalf4
3885           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3886           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3887      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3888           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3889           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3890           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3891           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3892           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3893           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3894      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3895           a_temp(1,1)=aggj(l,1)!+ghalf1
3896           a_temp(1,2)=aggj(l,2)!+ghalf2
3897           a_temp(2,1)=aggj(l,3)!+ghalf3
3898           a_temp(2,2)=aggj(l,4)!+ghalf4
3899           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3900           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3901      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3902           a_temp(1,1)=aggj1(l,1)
3903           a_temp(1,2)=aggj1(l,2)
3904           a_temp(2,1)=aggj1(l,3)
3905           a_temp(2,2)=aggj1(l,4)
3906           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3907           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3908      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3909         enddo
3910       return
3911       end
3912 C-------------------------------------------------------------------------------
3913       subroutine eturn4(i,eello_turn4)
3914 C Third- and fourth-order contributions from turns
3915       implicit real*8 (a-h,o-z)
3916       include 'DIMENSIONS'
3917       include 'COMMON.IOUNITS'
3918       include 'COMMON.GEO'
3919       include 'COMMON.VAR'
3920       include 'COMMON.LOCAL'
3921       include 'COMMON.CHAIN'
3922       include 'COMMON.DERIV'
3923       include 'COMMON.INTERACT'
3924       include 'COMMON.CONTACTS'
3925       include 'COMMON.TORSION'
3926       include 'COMMON.VECTORS'
3927       include 'COMMON.FFIELD'
3928       include 'COMMON.CONTROL'
3929       dimension ggg(3)
3930       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3931      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3932      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3933       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3934      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3935       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3936      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3937      &    num_conti,j1,j2
3938       j=i+3
3939 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3940 C
3941 C               Fourth-order contributions
3942 C
3943 C                 (i+3)o----(i+4)
3944 C                     /  |
3945 C               (i+2)o   |
3946 C                     \  |
3947 C                 (i+1)o----i
3948 C
3949 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3950 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3951 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3952         a_temp(1,1)=a22
3953         a_temp(1,2)=a23
3954         a_temp(2,1)=a32
3955         a_temp(2,2)=a33
3956         iti1=itortyp(itype(i+1))
3957         iti2=itortyp(itype(i+2))
3958         iti3=itortyp(itype(i+3))
3959 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3960         call transpose2(EUg(1,1,i+1),e1t(1,1))
3961         call transpose2(Eug(1,1,i+2),e2t(1,1))
3962         call transpose2(Eug(1,1,i+3),e3t(1,1))
3963         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3964         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3965         s1=scalar2(b1(1,iti2),auxvec(1))
3966         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3967         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3968         s2=scalar2(b1(1,iti1),auxvec(1))
3969         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3970         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3971         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3972         eello_turn4=eello_turn4-(s1+s2+s3)
3973         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3974      &      'eturn4',i,j,-(s1+s2+s3)
3975 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3976 cd     &    ' eello_turn4_num',8*eello_turn4_num
3977 C Derivatives in gamma(i)
3978         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3979         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3980         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3981         s1=scalar2(b1(1,iti2),auxvec(1))
3982         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3983         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3984         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3985 C Derivatives in gamma(i+1)
3986         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3987         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3988         s2=scalar2(b1(1,iti1),auxvec(1))
3989         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3990         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3991         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3992         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3993 C Derivatives in gamma(i+2)
3994         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3995         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3996         s1=scalar2(b1(1,iti2),auxvec(1))
3997         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3998         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3999         s2=scalar2(b1(1,iti1),auxvec(1))
4000         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4001         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4002         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4003         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4004 C Cartesian derivatives
4005 C Derivatives of this turn contributions in DC(i+2)
4006         if (j.lt.nres-1) then
4007           do l=1,3
4008             a_temp(1,1)=agg(l,1)
4009             a_temp(1,2)=agg(l,2)
4010             a_temp(2,1)=agg(l,3)
4011             a_temp(2,2)=agg(l,4)
4012             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4013             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4014             s1=scalar2(b1(1,iti2),auxvec(1))
4015             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4016             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4017             s2=scalar2(b1(1,iti1),auxvec(1))
4018             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4019             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4020             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4021             ggg(l)=-(s1+s2+s3)
4022             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4023           enddo
4024         endif
4025 C Remaining derivatives of this turn contribution
4026         do l=1,3
4027           a_temp(1,1)=aggi(l,1)
4028           a_temp(1,2)=aggi(l,2)
4029           a_temp(2,1)=aggi(l,3)
4030           a_temp(2,2)=aggi(l,4)
4031           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4032           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4033           s1=scalar2(b1(1,iti2),auxvec(1))
4034           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4035           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4036           s2=scalar2(b1(1,iti1),auxvec(1))
4037           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4038           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4039           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4040           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4041           a_temp(1,1)=aggi1(l,1)
4042           a_temp(1,2)=aggi1(l,2)
4043           a_temp(2,1)=aggi1(l,3)
4044           a_temp(2,2)=aggi1(l,4)
4045           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4046           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4047           s1=scalar2(b1(1,iti2),auxvec(1))
4048           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4049           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4050           s2=scalar2(b1(1,iti1),auxvec(1))
4051           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4052           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4053           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4054           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4055           a_temp(1,1)=aggj(l,1)
4056           a_temp(1,2)=aggj(l,2)
4057           a_temp(2,1)=aggj(l,3)
4058           a_temp(2,2)=aggj(l,4)
4059           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4060           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4061           s1=scalar2(b1(1,iti2),auxvec(1))
4062           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4063           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4064           s2=scalar2(b1(1,iti1),auxvec(1))
4065           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4066           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4067           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4068           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4069           a_temp(1,1)=aggj1(l,1)
4070           a_temp(1,2)=aggj1(l,2)
4071           a_temp(2,1)=aggj1(l,3)
4072           a_temp(2,2)=aggj1(l,4)
4073           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4074           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4075           s1=scalar2(b1(1,iti2),auxvec(1))
4076           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4077           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4078           s2=scalar2(b1(1,iti1),auxvec(1))
4079           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4080           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4081           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4082 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4083           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4084         enddo
4085       return
4086       end
4087 C-----------------------------------------------------------------------------
4088       subroutine vecpr(u,v,w)
4089       implicit real*8(a-h,o-z)
4090       dimension u(3),v(3),w(3)
4091       w(1)=u(2)*v(3)-u(3)*v(2)
4092       w(2)=-u(1)*v(3)+u(3)*v(1)
4093       w(3)=u(1)*v(2)-u(2)*v(1)
4094       return
4095       end
4096 C-----------------------------------------------------------------------------
4097       subroutine unormderiv(u,ugrad,unorm,ungrad)
4098 C This subroutine computes the derivatives of a normalized vector u, given
4099 C the derivatives computed without normalization conditions, ugrad. Returns
4100 C ungrad.
4101       implicit none
4102       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4103       double precision vec(3)
4104       double precision scalar
4105       integer i,j
4106 c      write (2,*) 'ugrad',ugrad
4107 c      write (2,*) 'u',u
4108       do i=1,3
4109         vec(i)=scalar(ugrad(1,i),u(1))
4110       enddo
4111 c      write (2,*) 'vec',vec
4112       do i=1,3
4113         do j=1,3
4114           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4115         enddo
4116       enddo
4117 c      write (2,*) 'ungrad',ungrad
4118       return
4119       end
4120 C-----------------------------------------------------------------------------
4121       subroutine escp_soft_sphere(evdw2,evdw2_14)
4122 C
4123 C This subroutine calculates the excluded-volume interaction energy between
4124 C peptide-group centers and side chains and its gradient in virtual-bond and
4125 C side-chain vectors.
4126 C
4127       implicit real*8 (a-h,o-z)
4128       include 'DIMENSIONS'
4129       include 'COMMON.GEO'
4130       include 'COMMON.VAR'
4131       include 'COMMON.LOCAL'
4132       include 'COMMON.CHAIN'
4133       include 'COMMON.DERIV'
4134       include 'COMMON.INTERACT'
4135       include 'COMMON.FFIELD'
4136       include 'COMMON.IOUNITS'
4137       include 'COMMON.CONTROL'
4138       dimension ggg(3)
4139       evdw2=0.0D0
4140       evdw2_14=0.0d0
4141       r0_scp=4.5d0
4142 cd    print '(a)','Enter ESCP'
4143 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4144       do i=iatscp_s,iatscp_e
4145         iteli=itel(i)
4146         xi=0.5D0*(c(1,i)+c(1,i+1))
4147         yi=0.5D0*(c(2,i)+c(2,i+1))
4148         zi=0.5D0*(c(3,i)+c(3,i+1))
4149
4150         do iint=1,nscp_gr(i)
4151
4152         do j=iscpstart(i,iint),iscpend(i,iint)
4153           itypj=itype(j)
4154 C Uncomment following three lines for SC-p interactions
4155 c         xj=c(1,nres+j)-xi
4156 c         yj=c(2,nres+j)-yi
4157 c         zj=c(3,nres+j)-zi
4158 C Uncomment following three lines for Ca-p interactions
4159           xj=c(1,j)-xi
4160           yj=c(2,j)-yi
4161           zj=c(3,j)-zi
4162           rij=xj*xj+yj*yj+zj*zj
4163           r0ij=r0_scp
4164           r0ijsq=r0ij*r0ij
4165           if (rij.lt.r0ijsq) then
4166             evdwij=0.25d0*(rij-r0ijsq)**2
4167             fac=rij-r0ijsq
4168           else
4169             evdwij=0.0d0
4170             fac=0.0d0
4171           endif
4172           evdw2=evdw2+evdwij
4173 C
4174 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4175 C
4176           ggg(1)=xj*fac
4177           ggg(2)=yj*fac
4178           ggg(3)=zj*fac
4179 cgrad          if (j.lt.i) then
4180 cd          write (iout,*) 'j<i'
4181 C Uncomment following three lines for SC-p interactions
4182 c           do k=1,3
4183 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4184 c           enddo
4185 cgrad          else
4186 cd          write (iout,*) 'j>i'
4187 cgrad            do k=1,3
4188 cgrad              ggg(k)=-ggg(k)
4189 C Uncomment following line for SC-p interactions
4190 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4191 cgrad            enddo
4192 cgrad          endif
4193 cgrad          do k=1,3
4194 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4195 cgrad          enddo
4196 cgrad          kstart=min0(i+1,j)
4197 cgrad          kend=max0(i-1,j-1)
4198 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4199 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4200 cgrad          do k=kstart,kend
4201 cgrad            do l=1,3
4202 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4203 cgrad            enddo
4204 cgrad          enddo
4205           do k=1,3
4206             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4207             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4208           enddo
4209         enddo
4210
4211         enddo ! iint
4212       enddo ! i
4213       return
4214       end
4215 C-----------------------------------------------------------------------------
4216       subroutine escp(evdw2,evdw2_14)
4217 C
4218 C This subroutine calculates the excluded-volume interaction energy between
4219 C peptide-group centers and side chains and its gradient in virtual-bond and
4220 C side-chain vectors.
4221 C
4222       implicit real*8 (a-h,o-z)
4223       include 'DIMENSIONS'
4224       include 'COMMON.GEO'
4225       include 'COMMON.VAR'
4226       include 'COMMON.LOCAL'
4227       include 'COMMON.CHAIN'
4228       include 'COMMON.DERIV'
4229       include 'COMMON.INTERACT'
4230       include 'COMMON.FFIELD'
4231       include 'COMMON.IOUNITS'
4232       include 'COMMON.CONTROL'
4233       dimension ggg(3)
4234       evdw2=0.0D0
4235       evdw2_14=0.0d0
4236 cd    print '(a)','Enter ESCP'
4237 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4238       do i=iatscp_s,iatscp_e
4239         iteli=itel(i)
4240         xi=0.5D0*(c(1,i)+c(1,i+1))
4241         yi=0.5D0*(c(2,i)+c(2,i+1))
4242         zi=0.5D0*(c(3,i)+c(3,i+1))
4243
4244         do iint=1,nscp_gr(i)
4245
4246         do j=iscpstart(i,iint),iscpend(i,iint)
4247           itypj=itype(j)
4248 C Uncomment following three lines for SC-p interactions
4249 c         xj=c(1,nres+j)-xi
4250 c         yj=c(2,nres+j)-yi
4251 c         zj=c(3,nres+j)-zi
4252 C Uncomment following three lines for Ca-p interactions
4253           xj=c(1,j)-xi
4254           yj=c(2,j)-yi
4255           zj=c(3,j)-zi
4256           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4257           fac=rrij**expon2
4258           e1=fac*fac*aad(itypj,iteli)
4259           e2=fac*bad(itypj,iteli)
4260           if (iabs(j-i) .le. 2) then
4261             e1=scal14*e1
4262             e2=scal14*e2
4263             evdw2_14=evdw2_14+e1+e2
4264           endif
4265           evdwij=e1+e2
4266           evdw2=evdw2+evdwij
4267           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4268      &        'evdw2',i,j,evdwij
4269 C
4270 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4271 C
4272           fac=-(evdwij+e1)*rrij
4273           ggg(1)=xj*fac
4274           ggg(2)=yj*fac
4275           ggg(3)=zj*fac
4276 cgrad          if (j.lt.i) then
4277 cd          write (iout,*) 'j<i'
4278 C Uncomment following three lines for SC-p interactions
4279 c           do k=1,3
4280 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4281 c           enddo
4282 cgrad          else
4283 cd          write (iout,*) 'j>i'
4284 cgrad            do k=1,3
4285 cgrad              ggg(k)=-ggg(k)
4286 C Uncomment following line for SC-p interactions
4287 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4288 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4289 cgrad            enddo
4290 cgrad          endif
4291 cgrad          do k=1,3
4292 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4293 cgrad          enddo
4294 cgrad          kstart=min0(i+1,j)
4295 cgrad          kend=max0(i-1,j-1)
4296 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4297 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4298 cgrad          do k=kstart,kend
4299 cgrad            do l=1,3
4300 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4301 cgrad            enddo
4302 cgrad          enddo
4303           do k=1,3
4304             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4305             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4306           enddo
4307         enddo
4308
4309         enddo ! iint
4310       enddo ! i
4311       do i=1,nct
4312         do j=1,3
4313           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4314           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4315           gradx_scp(j,i)=expon*gradx_scp(j,i)
4316         enddo
4317       enddo
4318 C******************************************************************************
4319 C
4320 C                              N O T E !!!
4321 C
4322 C To save time the factor EXPON has been extracted from ALL components
4323 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4324 C use!
4325 C
4326 C******************************************************************************
4327       return
4328       end
4329 C--------------------------------------------------------------------------
4330       subroutine edis(ehpb)
4331 C
4332 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4333 C
4334       implicit real*8 (a-h,o-z)
4335       include 'DIMENSIONS'
4336       include 'COMMON.SBRIDGE'
4337       include 'COMMON.CHAIN'
4338       include 'COMMON.DERIV'
4339       include 'COMMON.VAR'
4340       include 'COMMON.INTERACT'
4341       include 'COMMON.IOUNITS'
4342       dimension ggg(3)
4343       ehpb=0.0D0
4344 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4345 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4346       if (link_end.eq.0) return
4347       do i=link_start,link_end
4348 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4349 C CA-CA distance used in regularization of structure.
4350         ii=ihpb(i)
4351         jj=jhpb(i)
4352 C iii and jjj point to the residues for which the distance is assigned.
4353         if (ii.gt.nres) then
4354           iii=ii-nres
4355           jjj=jj-nres
4356         else
4357           iii=ii
4358           jjj=jj
4359         endif
4360 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4361 c     &    dhpb(i),dhpb1(i),forcon(i)
4362 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4363 C    distance and angle dependent SS bond potential.
4364 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4365 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4366         if (.not.dyn_ss .and. i.le.nss) then
4367 C 15/02/13 CC dynamic SSbond - additional check
4368          if (ii.gt.nres
4369      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4370           call ssbond_ene(iii,jjj,eij)
4371           ehpb=ehpb+2*eij
4372          endif
4373 cd          write (iout,*) "eij",eij
4374         else if (ii.gt.nres .and. jj.gt.nres) then
4375 c Restraints from contact prediction
4376           dd=dist(ii,jj)
4377           if (dhpb1(i).gt.0.0d0) then
4378             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4379             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4380 c            write (iout,*) "beta nmr",
4381 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4382           else
4383             dd=dist(ii,jj)
4384             rdis=dd-dhpb(i)
4385 C Get the force constant corresponding to this distance.
4386             waga=forcon(i)
4387 C Calculate the contribution to energy.
4388             ehpb=ehpb+waga*rdis*rdis
4389 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4390 C
4391 C Evaluate gradient.
4392 C
4393             fac=waga*rdis/dd
4394           endif
4395           do j=1,3
4396             ggg(j)=fac*(c(j,jj)-c(j,ii))
4397           enddo
4398           do j=1,3
4399             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4400             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4401           enddo
4402           do k=1,3
4403             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4404             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4405           enddo
4406         else
4407 C Calculate the distance between the two points and its difference from the
4408 C target distance.
4409           dd=dist(ii,jj)
4410           if (dhpb1(i).gt.0.0d0) then
4411             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4412             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4413 c            write (iout,*) "alph nmr",
4414 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4415           else
4416             rdis=dd-dhpb(i)
4417 C Get the force constant corresponding to this distance.
4418             waga=forcon(i)
4419 C Calculate the contribution to energy.
4420             ehpb=ehpb+waga*rdis*rdis
4421 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4422 C
4423 C Evaluate gradient.
4424 C
4425             fac=waga*rdis/dd
4426           endif
4427 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4428 cd   &   ' waga=',waga,' fac=',fac
4429             do j=1,3
4430               ggg(j)=fac*(c(j,jj)-c(j,ii))
4431             enddo
4432 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4433 C If this is a SC-SC distance, we need to calculate the contributions to the
4434 C Cartesian gradient in the SC vectors (ghpbx).
4435           if (iii.lt.ii) then
4436           do j=1,3
4437             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4438             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4439           enddo
4440           endif
4441 cgrad        do j=iii,jjj-1
4442 cgrad          do k=1,3
4443 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4444 cgrad          enddo
4445 cgrad        enddo
4446           do k=1,3
4447             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4448             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4449           enddo
4450         endif
4451       enddo
4452       ehpb=0.5D0*ehpb
4453       return
4454       end
4455 C--------------------------------------------------------------------------
4456       subroutine ssbond_ene(i,j,eij)
4457 C
4458 C Calculate the distance and angle dependent SS-bond potential energy
4459 C using a free-energy function derived based on RHF/6-31G** ab initio
4460 C calculations of diethyl disulfide.
4461 C
4462 C A. Liwo and U. Kozlowska, 11/24/03
4463 C
4464       implicit real*8 (a-h,o-z)
4465       include 'DIMENSIONS'
4466       include 'COMMON.SBRIDGE'
4467       include 'COMMON.CHAIN'
4468       include 'COMMON.DERIV'
4469       include 'COMMON.LOCAL'
4470       include 'COMMON.INTERACT'
4471       include 'COMMON.VAR'
4472       include 'COMMON.IOUNITS'
4473       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4474       itypi=itype(i)
4475       xi=c(1,nres+i)
4476       yi=c(2,nres+i)
4477       zi=c(3,nres+i)
4478       dxi=dc_norm(1,nres+i)
4479       dyi=dc_norm(2,nres+i)
4480       dzi=dc_norm(3,nres+i)
4481 c      dsci_inv=dsc_inv(itypi)
4482       dsci_inv=vbld_inv(nres+i)
4483       itypj=itype(j)
4484 c      dscj_inv=dsc_inv(itypj)
4485       dscj_inv=vbld_inv(nres+j)
4486       xj=c(1,nres+j)-xi
4487       yj=c(2,nres+j)-yi
4488       zj=c(3,nres+j)-zi
4489       dxj=dc_norm(1,nres+j)
4490       dyj=dc_norm(2,nres+j)
4491       dzj=dc_norm(3,nres+j)
4492       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4493       rij=dsqrt(rrij)
4494       erij(1)=xj*rij
4495       erij(2)=yj*rij
4496       erij(3)=zj*rij
4497       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4498       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4499       om12=dxi*dxj+dyi*dyj+dzi*dzj
4500       do k=1,3
4501         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4502         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4503       enddo
4504       rij=1.0d0/rij
4505       deltad=rij-d0cm
4506       deltat1=1.0d0-om1
4507       deltat2=1.0d0+om2
4508       deltat12=om2-om1+2.0d0
4509       cosphi=om12-om1*om2
4510       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4511      &  +akct*deltad*deltat12+ebr
4512      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4513 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4514 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4515 c     &  " deltat12",deltat12," eij",eij
4516       ed=2*akcm*deltad+akct*deltat12
4517       pom1=akct*deltad
4518       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4519       eom1=-2*akth*deltat1-pom1-om2*pom2
4520       eom2= 2*akth*deltat2+pom1-om1*pom2
4521       eom12=pom2
4522       do k=1,3
4523         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4524         ghpbx(k,i)=ghpbx(k,i)-ggk
4525      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4526      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4527         ghpbx(k,j)=ghpbx(k,j)+ggk
4528      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4529      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4530         ghpbc(k,i)=ghpbc(k,i)-ggk
4531         ghpbc(k,j)=ghpbc(k,j)+ggk
4532       enddo
4533 C
4534 C Calculate the components of the gradient in DC and X
4535 C
4536 cgrad      do k=i,j-1
4537 cgrad        do l=1,3
4538 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4539 cgrad        enddo
4540 cgrad      enddo
4541       return
4542       end
4543 C--------------------------------------------------------------------------
4544       subroutine ebond(estr)
4545 c
4546 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4547 c
4548       implicit real*8 (a-h,o-z)
4549       include 'DIMENSIONS'
4550       include 'COMMON.LOCAL'
4551       include 'COMMON.GEO'
4552       include 'COMMON.INTERACT'
4553       include 'COMMON.DERIV'
4554       include 'COMMON.VAR'
4555       include 'COMMON.CHAIN'
4556       include 'COMMON.IOUNITS'
4557       include 'COMMON.NAMES'
4558       include 'COMMON.FFIELD'
4559       include 'COMMON.CONTROL'
4560       include 'COMMON.SETUP'
4561       double precision u(3),ud(3)
4562       estr=0.0d0
4563       do i=ibondp_start,ibondp_end
4564         diff = vbld(i)-vbldp0
4565 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4566         estr=estr+diff*diff
4567         do j=1,3
4568           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4569         enddo
4570 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4571       enddo
4572       estr=0.5d0*AKP*estr
4573 c
4574 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4575 c
4576       do i=ibond_start,ibond_end
4577         iti=itype(i)
4578         if (iti.ne.10) then
4579           nbi=nbondterm(iti)
4580           if (nbi.eq.1) then
4581             diff=vbld(i+nres)-vbldsc0(1,iti)
4582 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4583 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4584             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4585             do j=1,3
4586               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4587             enddo
4588           else
4589             do j=1,nbi
4590               diff=vbld(i+nres)-vbldsc0(j,iti)
4591               ud(j)=aksc(j,iti)*diff
4592               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4593             enddo
4594             uprod=u(1)
4595             do j=2,nbi
4596               uprod=uprod*u(j)
4597             enddo
4598             usum=0.0d0
4599             usumsqder=0.0d0
4600             do j=1,nbi
4601               uprod1=1.0d0
4602               uprod2=1.0d0
4603               do k=1,nbi
4604                 if (k.ne.j) then
4605                   uprod1=uprod1*u(k)
4606                   uprod2=uprod2*u(k)*u(k)
4607                 endif
4608               enddo
4609               usum=usum+uprod1
4610               usumsqder=usumsqder+ud(j)*uprod2
4611             enddo
4612             estr=estr+uprod/usum
4613             do j=1,3
4614              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4615             enddo
4616           endif
4617         endif
4618       enddo
4619       return
4620       end
4621 #ifdef CRYST_THETA
4622 C--------------------------------------------------------------------------
4623       subroutine ebend(etheta)
4624 C
4625 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4626 C angles gamma and its derivatives in consecutive thetas and gammas.
4627 C
4628       implicit real*8 (a-h,o-z)
4629       include 'DIMENSIONS'
4630       include 'COMMON.LOCAL'
4631       include 'COMMON.GEO'
4632       include 'COMMON.INTERACT'
4633       include 'COMMON.DERIV'
4634       include 'COMMON.VAR'
4635       include 'COMMON.CHAIN'
4636       include 'COMMON.IOUNITS'
4637       include 'COMMON.NAMES'
4638       include 'COMMON.FFIELD'
4639       include 'COMMON.CONTROL'
4640       common /calcthet/ term1,term2,termm,diffak,ratak,
4641      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4642      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4643       double precision y(2),z(2)
4644       delta=0.02d0*pi
4645 c      time11=dexp(-2*time)
4646 c      time12=1.0d0
4647       etheta=0.0D0
4648 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4649       do i=ithet_start,ithet_end
4650 C Zero the energy function and its derivative at 0 or pi.
4651         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4652         it=itype(i-1)
4653         if (i.gt.3) then
4654 #ifdef OSF
4655           phii=phi(i)
4656           if (phii.ne.phii) phii=150.0
4657 #else
4658           phii=phi(i)
4659 #endif
4660           y(1)=dcos(phii)
4661           y(2)=dsin(phii)
4662         else
4663           y(1)=0.0D0
4664           y(2)=0.0D0
4665         endif
4666         if (i.lt.nres) then
4667 #ifdef OSF
4668           phii1=phi(i+1)
4669           if (phii1.ne.phii1) phii1=150.0
4670           phii1=pinorm(phii1)
4671           z(1)=cos(phii1)
4672 #else
4673           phii1=phi(i+1)
4674           z(1)=dcos(phii1)
4675 #endif
4676           z(2)=dsin(phii1)
4677         else
4678           z(1)=0.0D0
4679           z(2)=0.0D0
4680         endif
4681 C Calculate the "mean" value of theta from the part of the distribution
4682 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4683 C In following comments this theta will be referred to as t_c.
4684         thet_pred_mean=0.0d0
4685         do k=1,2
4686           athetk=athet(k,it)
4687           bthetk=bthet(k,it)
4688           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4689         enddo
4690         dthett=thet_pred_mean*ssd
4691         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4692 C Derivatives of the "mean" values in gamma1 and gamma2.
4693         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4694         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4695         if (theta(i).gt.pi-delta) then
4696           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4697      &         E_tc0)
4698           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4699           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4700           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4701      &        E_theta)
4702           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4703      &        E_tc)
4704         else if (theta(i).lt.delta) then
4705           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4706           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4707           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4708      &        E_theta)
4709           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4710           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4711      &        E_tc)
4712         else
4713           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4714      &        E_theta,E_tc)
4715         endif
4716         etheta=etheta+ethetai
4717         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4718      &      'ebend',i,ethetai
4719         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4720         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4721         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4722       enddo
4723 C Ufff.... We've done all this!!!
4724       return
4725       end
4726 C---------------------------------------------------------------------------
4727       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4728      &     E_tc)
4729       implicit real*8 (a-h,o-z)
4730       include 'DIMENSIONS'
4731       include 'COMMON.LOCAL'
4732       include 'COMMON.IOUNITS'
4733       common /calcthet/ term1,term2,termm,diffak,ratak,
4734      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4735      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4736 C Calculate the contributions to both Gaussian lobes.
4737 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4738 C The "polynomial part" of the "standard deviation" of this part of
4739 C the distribution.
4740         sig=polthet(3,it)
4741         do j=2,0,-1
4742           sig=sig*thet_pred_mean+polthet(j,it)
4743         enddo
4744 C Derivative of the "interior part" of the "standard deviation of the"
4745 C gamma-dependent Gaussian lobe in t_c.
4746         sigtc=3*polthet(3,it)
4747         do j=2,1,-1
4748           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4749         enddo
4750         sigtc=sig*sigtc
4751 C Set the parameters of both Gaussian lobes of the distribution.
4752 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4753         fac=sig*sig+sigc0(it)
4754         sigcsq=fac+fac
4755         sigc=1.0D0/sigcsq
4756 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4757         sigsqtc=-4.0D0*sigcsq*sigtc
4758 c       print *,i,sig,sigtc,sigsqtc
4759 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4760         sigtc=-sigtc/(fac*fac)
4761 C Following variable is sigma(t_c)**(-2)
4762         sigcsq=sigcsq*sigcsq
4763         sig0i=sig0(it)
4764         sig0inv=1.0D0/sig0i**2
4765         delthec=thetai-thet_pred_mean
4766         delthe0=thetai-theta0i
4767         term1=-0.5D0*sigcsq*delthec*delthec
4768         term2=-0.5D0*sig0inv*delthe0*delthe0
4769 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4770 C NaNs in taking the logarithm. We extract the largest exponent which is added
4771 C to the energy (this being the log of the distribution) at the end of energy
4772 C term evaluation for this virtual-bond angle.
4773         if (term1.gt.term2) then
4774           termm=term1
4775           term2=dexp(term2-termm)
4776           term1=1.0d0
4777         else
4778           termm=term2
4779           term1=dexp(term1-termm)
4780           term2=1.0d0
4781         endif
4782 C The ratio between the gamma-independent and gamma-dependent lobes of
4783 C the distribution is a Gaussian function of thet_pred_mean too.
4784         diffak=gthet(2,it)-thet_pred_mean
4785         ratak=diffak/gthet(3,it)**2
4786         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4787 C Let's differentiate it in thet_pred_mean NOW.
4788         aktc=ak*ratak
4789 C Now put together the distribution terms to make complete distribution.
4790         termexp=term1+ak*term2
4791         termpre=sigc+ak*sig0i
4792 C Contribution of the bending energy from this theta is just the -log of
4793 C the sum of the contributions from the two lobes and the pre-exponential
4794 C factor. Simple enough, isn't it?
4795         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4796 C NOW the derivatives!!!
4797 C 6/6/97 Take into account the deformation.
4798         E_theta=(delthec*sigcsq*term1
4799      &       +ak*delthe0*sig0inv*term2)/termexp
4800         E_tc=((sigtc+aktc*sig0i)/termpre
4801      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4802      &       aktc*term2)/termexp)
4803       return
4804       end
4805 c-----------------------------------------------------------------------------
4806       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4807       implicit real*8 (a-h,o-z)
4808       include 'DIMENSIONS'
4809       include 'COMMON.LOCAL'
4810       include 'COMMON.IOUNITS'
4811       common /calcthet/ term1,term2,termm,diffak,ratak,
4812      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4813      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4814       delthec=thetai-thet_pred_mean
4815       delthe0=thetai-theta0i
4816 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4817       t3 = thetai-thet_pred_mean
4818       t6 = t3**2
4819       t9 = term1
4820       t12 = t3*sigcsq
4821       t14 = t12+t6*sigsqtc
4822       t16 = 1.0d0
4823       t21 = thetai-theta0i
4824       t23 = t21**2
4825       t26 = term2
4826       t27 = t21*t26
4827       t32 = termexp
4828       t40 = t32**2
4829       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4830      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4831      & *(-t12*t9-ak*sig0inv*t27)
4832       return
4833       end
4834 #else
4835 C--------------------------------------------------------------------------
4836       subroutine ebend(etheta)
4837 C
4838 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4839 C angles gamma and its derivatives in consecutive thetas and gammas.
4840 C ab initio-derived potentials from
4841 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4842 C
4843       implicit real*8 (a-h,o-z)
4844       include 'DIMENSIONS'
4845       include 'COMMON.LOCAL'
4846       include 'COMMON.GEO'
4847       include 'COMMON.INTERACT'
4848       include 'COMMON.DERIV'
4849       include 'COMMON.VAR'
4850       include 'COMMON.CHAIN'
4851       include 'COMMON.IOUNITS'
4852       include 'COMMON.NAMES'
4853       include 'COMMON.FFIELD'
4854       include 'COMMON.CONTROL'
4855       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4856      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4857      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4858      & sinph1ph2(maxdouble,maxdouble)
4859       logical lprn /.false./, lprn1 /.false./
4860       etheta=0.0D0
4861       do i=ithet_start,ithet_end
4862         dethetai=0.0d0
4863         dephii=0.0d0
4864         dephii1=0.0d0
4865         theti2=0.5d0*theta(i)
4866         ityp2=ithetyp(itype(i-1))
4867         do k=1,nntheterm
4868           coskt(k)=dcos(k*theti2)
4869           sinkt(k)=dsin(k*theti2)
4870         enddo
4871         if (i.gt.3) then
4872 #ifdef OSF
4873           phii=phi(i)
4874           if (phii.ne.phii) phii=150.0
4875 #else
4876           phii=phi(i)
4877 #endif
4878           ityp1=ithetyp(itype(i-2))
4879           do k=1,nsingle
4880             cosph1(k)=dcos(k*phii)
4881             sinph1(k)=dsin(k*phii)
4882           enddo
4883         else
4884           phii=0.0d0
4885           ityp1=nthetyp+1
4886           do k=1,nsingle
4887             cosph1(k)=0.0d0
4888             sinph1(k)=0.0d0
4889           enddo
4890         endif
4891         if (i.lt.nres) then
4892 #ifdef OSF
4893           phii1=phi(i+1)
4894           if (phii1.ne.phii1) phii1=150.0
4895           phii1=pinorm(phii1)
4896 #else
4897           phii1=phi(i+1)
4898 #endif
4899           ityp3=ithetyp(itype(i))
4900           do k=1,nsingle
4901             cosph2(k)=dcos(k*phii1)
4902             sinph2(k)=dsin(k*phii1)
4903           enddo
4904         else
4905           phii1=0.0d0
4906           ityp3=nthetyp+1
4907           do k=1,nsingle
4908             cosph2(k)=0.0d0
4909             sinph2(k)=0.0d0
4910           enddo
4911         endif
4912         ethetai=aa0thet(ityp1,ityp2,ityp3)
4913         do k=1,ndouble
4914           do l=1,k-1
4915             ccl=cosph1(l)*cosph2(k-l)
4916             ssl=sinph1(l)*sinph2(k-l)
4917             scl=sinph1(l)*cosph2(k-l)
4918             csl=cosph1(l)*sinph2(k-l)
4919             cosph1ph2(l,k)=ccl-ssl
4920             cosph1ph2(k,l)=ccl+ssl
4921             sinph1ph2(l,k)=scl+csl
4922             sinph1ph2(k,l)=scl-csl
4923           enddo
4924         enddo
4925         if (lprn) then
4926         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4927      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4928         write (iout,*) "coskt and sinkt"
4929         do k=1,nntheterm
4930           write (iout,*) k,coskt(k),sinkt(k)
4931         enddo
4932         endif
4933         do k=1,ntheterm
4934           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4935           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4936      &      *coskt(k)
4937           if (lprn)
4938      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4939      &     " ethetai",ethetai
4940         enddo
4941         if (lprn) then
4942         write (iout,*) "cosph and sinph"
4943         do k=1,nsingle
4944           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4945         enddo
4946         write (iout,*) "cosph1ph2 and sinph2ph2"
4947         do k=2,ndouble
4948           do l=1,k-1
4949             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4950      &         sinph1ph2(l,k),sinph1ph2(k,l)
4951           enddo
4952         enddo
4953         write(iout,*) "ethetai",ethetai
4954         endif
4955         do m=1,ntheterm2
4956           do k=1,nsingle
4957             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4958      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4959      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4960      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4961             ethetai=ethetai+sinkt(m)*aux
4962             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4963             dephii=dephii+k*sinkt(m)*(
4964      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4965      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4966             dephii1=dephii1+k*sinkt(m)*(
4967      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4968      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4969             if (lprn)
4970      &      write (iout,*) "m",m," k",k," bbthet",
4971      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4972      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4973      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4974      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4975           enddo
4976         enddo
4977         if (lprn)
4978      &  write(iout,*) "ethetai",ethetai
4979         do m=1,ntheterm3
4980           do k=2,ndouble
4981             do l=1,k-1
4982               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4983      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4984      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4985      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4986               ethetai=ethetai+sinkt(m)*aux
4987               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4988               dephii=dephii+l*sinkt(m)*(
4989      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4990      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4991      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4992      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4993               dephii1=dephii1+(k-l)*sinkt(m)*(
4994      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4995      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4996      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4997      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4998               if (lprn) then
4999               write (iout,*) "m",m," k",k," l",l," ffthet",
5000      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5001      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5002      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5003      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5004               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5005      &            cosph1ph2(k,l)*sinkt(m),
5006      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5007               endif
5008             enddo
5009           enddo
5010         enddo
5011 10      continue
5012 c        lprn1=.true.
5013         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
5014      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
5015      &   phii1*rad2deg,ethetai
5016 c        lprn1=.false.
5017         etheta=etheta+ethetai
5018         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5019         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5020         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5021       enddo
5022       return
5023       end
5024 #endif
5025 #ifdef CRYST_SC
5026 c-----------------------------------------------------------------------------
5027       subroutine esc(escloc)
5028 C Calculate the local energy of a side chain and its derivatives in the
5029 C corresponding virtual-bond valence angles THETA and the spherical angles
5030 C ALPHA and OMEGA.
5031       implicit real*8 (a-h,o-z)
5032       include 'DIMENSIONS'
5033       include 'COMMON.GEO'
5034       include 'COMMON.LOCAL'
5035       include 'COMMON.VAR'
5036       include 'COMMON.INTERACT'
5037       include 'COMMON.DERIV'
5038       include 'COMMON.CHAIN'
5039       include 'COMMON.IOUNITS'
5040       include 'COMMON.NAMES'
5041       include 'COMMON.FFIELD'
5042       include 'COMMON.CONTROL'
5043       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5044      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5045       common /sccalc/ time11,time12,time112,theti,it,nlobit
5046       delta=0.02d0*pi
5047       escloc=0.0D0
5048 c     write (iout,'(a)') 'ESC'
5049       do i=loc_start,loc_end
5050         it=itype(i)
5051         if (it.eq.10) goto 1
5052         nlobit=nlob(it)
5053 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5054 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5055         theti=theta(i+1)-pipol
5056         x(1)=dtan(theti)
5057         x(2)=alph(i)
5058         x(3)=omeg(i)
5059
5060         if (x(2).gt.pi-delta) then
5061           xtemp(1)=x(1)
5062           xtemp(2)=pi-delta
5063           xtemp(3)=x(3)
5064           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5065           xtemp(2)=pi
5066           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5067           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5068      &        escloci,dersc(2))
5069           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5070      &        ddersc0(1),dersc(1))
5071           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5072      &        ddersc0(3),dersc(3))
5073           xtemp(2)=pi-delta
5074           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5075           xtemp(2)=pi
5076           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5077           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5078      &            dersc0(2),esclocbi,dersc02)
5079           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5080      &            dersc12,dersc01)
5081           call splinthet(x(2),0.5d0*delta,ss,ssd)
5082           dersc0(1)=dersc01
5083           dersc0(2)=dersc02
5084           dersc0(3)=0.0d0
5085           do k=1,3
5086             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5087           enddo
5088           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5089 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5090 c    &             esclocbi,ss,ssd
5091           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5092 c         escloci=esclocbi
5093 c         write (iout,*) escloci
5094         else if (x(2).lt.delta) then
5095           xtemp(1)=x(1)
5096           xtemp(2)=delta
5097           xtemp(3)=x(3)
5098           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5099           xtemp(2)=0.0d0
5100           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5101           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5102      &        escloci,dersc(2))
5103           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5104      &        ddersc0(1),dersc(1))
5105           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5106      &        ddersc0(3),dersc(3))
5107           xtemp(2)=delta
5108           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5109           xtemp(2)=0.0d0
5110           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5111           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5112      &            dersc0(2),esclocbi,dersc02)
5113           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5114      &            dersc12,dersc01)
5115           dersc0(1)=dersc01
5116           dersc0(2)=dersc02
5117           dersc0(3)=0.0d0
5118           call splinthet(x(2),0.5d0*delta,ss,ssd)
5119           do k=1,3
5120             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5121           enddo
5122           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5123 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5124 c    &             esclocbi,ss,ssd
5125           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5126 c         write (iout,*) escloci
5127         else
5128           call enesc(x,escloci,dersc,ddummy,.false.)
5129         endif
5130
5131         escloc=escloc+escloci
5132         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5133      &     'escloc',i,escloci
5134 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5135
5136         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5137      &   wscloc*dersc(1)
5138         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5139         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5140     1   continue
5141       enddo
5142       return
5143       end
5144 C---------------------------------------------------------------------------
5145       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5146       implicit real*8 (a-h,o-z)
5147       include 'DIMENSIONS'
5148       include 'COMMON.GEO'
5149       include 'COMMON.LOCAL'
5150       include 'COMMON.IOUNITS'
5151       common /sccalc/ time11,time12,time112,theti,it,nlobit
5152       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5153       double precision contr(maxlob,-1:1)
5154       logical mixed
5155 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5156         escloc_i=0.0D0
5157         do j=1,3
5158           dersc(j)=0.0D0
5159           if (mixed) ddersc(j)=0.0d0
5160         enddo
5161         x3=x(3)
5162
5163 C Because of periodicity of the dependence of the SC energy in omega we have
5164 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5165 C To avoid underflows, first compute & store the exponents.
5166
5167         do iii=-1,1
5168
5169           x(3)=x3+iii*dwapi
5170
5171           do j=1,nlobit
5172             do k=1,3
5173               z(k)=x(k)-censc(k,j,it)
5174             enddo
5175             do k=1,3
5176               Axk=0.0D0
5177               do l=1,3
5178                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5179               enddo
5180               Ax(k,j,iii)=Axk
5181             enddo
5182             expfac=0.0D0
5183             do k=1,3
5184               expfac=expfac+Ax(k,j,iii)*z(k)
5185             enddo
5186             contr(j,iii)=expfac
5187           enddo ! j
5188
5189         enddo ! iii
5190
5191         x(3)=x3
5192 C As in the case of ebend, we want to avoid underflows in exponentiation and
5193 C subsequent NaNs and INFs in energy calculation.
5194 C Find the largest exponent
5195         emin=contr(1,-1)
5196         do iii=-1,1
5197           do j=1,nlobit
5198             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5199           enddo
5200         enddo
5201         emin=0.5D0*emin
5202 cd      print *,'it=',it,' emin=',emin
5203
5204 C Compute the contribution to SC energy and derivatives
5205         do iii=-1,1
5206
5207           do j=1,nlobit
5208 #ifdef OSF
5209             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5210             if(adexp.ne.adexp) adexp=1.0
5211             expfac=dexp(adexp)
5212 #else
5213             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5214 #endif
5215 cd          print *,'j=',j,' expfac=',expfac
5216             escloc_i=escloc_i+expfac
5217             do k=1,3
5218               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5219             enddo
5220             if (mixed) then
5221               do k=1,3,2
5222                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5223      &            +gaussc(k,2,j,it))*expfac
5224               enddo
5225             endif
5226           enddo
5227
5228         enddo ! iii
5229
5230         dersc(1)=dersc(1)/cos(theti)**2
5231         ddersc(1)=ddersc(1)/cos(theti)**2
5232         ddersc(3)=ddersc(3)
5233
5234         escloci=-(dlog(escloc_i)-emin)
5235         do j=1,3
5236           dersc(j)=dersc(j)/escloc_i
5237         enddo
5238         if (mixed) then
5239           do j=1,3,2
5240             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5241           enddo
5242         endif
5243       return
5244       end
5245 C------------------------------------------------------------------------------
5246       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5247       implicit real*8 (a-h,o-z)
5248       include 'DIMENSIONS'
5249       include 'COMMON.GEO'
5250       include 'COMMON.LOCAL'
5251       include 'COMMON.IOUNITS'
5252       common /sccalc/ time11,time12,time112,theti,it,nlobit
5253       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5254       double precision contr(maxlob)
5255       logical mixed
5256
5257       escloc_i=0.0D0
5258
5259       do j=1,3
5260         dersc(j)=0.0D0
5261       enddo
5262
5263       do j=1,nlobit
5264         do k=1,2
5265           z(k)=x(k)-censc(k,j,it)
5266         enddo
5267         z(3)=dwapi
5268         do k=1,3
5269           Axk=0.0D0
5270           do l=1,3
5271             Axk=Axk+gaussc(l,k,j,it)*z(l)
5272           enddo
5273           Ax(k,j)=Axk
5274         enddo
5275         expfac=0.0D0
5276         do k=1,3
5277           expfac=expfac+Ax(k,j)*z(k)
5278         enddo
5279         contr(j)=expfac
5280       enddo ! j
5281
5282 C As in the case of ebend, we want to avoid underflows in exponentiation and
5283 C subsequent NaNs and INFs in energy calculation.
5284 C Find the largest exponent
5285       emin=contr(1)
5286       do j=1,nlobit
5287         if (emin.gt.contr(j)) emin=contr(j)
5288       enddo
5289       emin=0.5D0*emin
5290
5291 C Compute the contribution to SC energy and derivatives
5292
5293       dersc12=0.0d0
5294       do j=1,nlobit
5295         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5296         escloc_i=escloc_i+expfac
5297         do k=1,2
5298           dersc(k)=dersc(k)+Ax(k,j)*expfac
5299         enddo
5300         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5301      &            +gaussc(1,2,j,it))*expfac
5302         dersc(3)=0.0d0
5303       enddo
5304
5305       dersc(1)=dersc(1)/cos(theti)**2
5306       dersc12=dersc12/cos(theti)**2
5307       escloci=-(dlog(escloc_i)-emin)
5308       do j=1,2
5309         dersc(j)=dersc(j)/escloc_i
5310       enddo
5311       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5312       return
5313       end
5314 #else
5315 c----------------------------------------------------------------------------------
5316       subroutine esc(escloc)
5317 C Calculate the local energy of a side chain and its derivatives in the
5318 C corresponding virtual-bond valence angles THETA and the spherical angles
5319 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5320 C added by Urszula Kozlowska. 07/11/2007
5321 C
5322       implicit real*8 (a-h,o-z)
5323       include 'DIMENSIONS'
5324       include 'COMMON.GEO'
5325       include 'COMMON.LOCAL'
5326       include 'COMMON.VAR'
5327       include 'COMMON.SCROT'
5328       include 'COMMON.INTERACT'
5329       include 'COMMON.DERIV'
5330       include 'COMMON.CHAIN'
5331       include 'COMMON.IOUNITS'
5332       include 'COMMON.NAMES'
5333       include 'COMMON.FFIELD'
5334       include 'COMMON.CONTROL'
5335       include 'COMMON.VECTORS'
5336       double precision x_prime(3),y_prime(3),z_prime(3)
5337      &    , sumene,dsc_i,dp2_i,x(65),
5338      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5339      &    de_dxx,de_dyy,de_dzz,de_dt
5340       double precision s1_t,s1_6_t,s2_t,s2_6_t
5341       double precision
5342      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5343      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5344      & dt_dCi(3),dt_dCi1(3)
5345       common /sccalc/ time11,time12,time112,theti,it,nlobit
5346       delta=0.02d0*pi
5347       escloc=0.0D0
5348       do i=loc_start,loc_end
5349         costtab(i+1) =dcos(theta(i+1))
5350         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5351         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5352         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5353         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5354         cosfac=dsqrt(cosfac2)
5355         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5356         sinfac=dsqrt(sinfac2)
5357         it=itype(i)
5358         if (it.eq.10) goto 1
5359 c
5360 C  Compute the axes of tghe local cartesian coordinates system; store in
5361 c   x_prime, y_prime and z_prime
5362 c
5363         do j=1,3
5364           x_prime(j) = 0.00
5365           y_prime(j) = 0.00
5366           z_prime(j) = 0.00
5367         enddo
5368 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5369 C     &   dc_norm(3,i+nres)
5370         do j = 1,3
5371           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5372           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5373         enddo
5374         do j = 1,3
5375           z_prime(j) = -uz(j,i-1)
5376         enddo
5377 c       write (2,*) "i",i
5378 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5379 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5380 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5381 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5382 c      & " xy",scalar(x_prime(1),y_prime(1)),
5383 c      & " xz",scalar(x_prime(1),z_prime(1)),
5384 c      & " yy",scalar(y_prime(1),y_prime(1)),
5385 c      & " yz",scalar(y_prime(1),z_prime(1)),
5386 c      & " zz",scalar(z_prime(1),z_prime(1))
5387 c
5388 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5389 C to local coordinate system. Store in xx, yy, zz.
5390 c
5391         xx=0.0d0
5392         yy=0.0d0
5393         zz=0.0d0
5394         do j = 1,3
5395           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5396           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5397           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5398         enddo
5399
5400         xxtab(i)=xx
5401         yytab(i)=yy
5402         zztab(i)=zz
5403 C
5404 C Compute the energy of the ith side cbain
5405 C
5406 c        write (2,*) "xx",xx," yy",yy," zz",zz
5407         it=itype(i)
5408         do j = 1,65
5409           x(j) = sc_parmin(j,it)
5410         enddo
5411 #ifdef CHECK_COORD
5412 Cc diagnostics - remove later
5413         xx1 = dcos(alph(2))
5414         yy1 = dsin(alph(2))*dcos(omeg(2))
5415         zz1 = -dsin(alph(2))*dsin(omeg(2))
5416         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5417      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5418      &    xx1,yy1,zz1
5419 C,"  --- ", xx_w,yy_w,zz_w
5420 c end diagnostics
5421 #endif
5422         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5423      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5424      &   + x(10)*yy*zz
5425         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5426      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5427      & + x(20)*yy*zz
5428         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5429      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5430      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5431      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5432      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5433      &  +x(40)*xx*yy*zz
5434         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5435      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5436      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5437      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5438      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5439      &  +x(60)*xx*yy*zz
5440         dsc_i   = 0.743d0+x(61)
5441         dp2_i   = 1.9d0+x(62)
5442         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5443      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5444         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5445      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5446         s1=(1+x(63))/(0.1d0 + dscp1)
5447         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5448         s2=(1+x(65))/(0.1d0 + dscp2)
5449         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5450         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5451      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5452 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5453 c     &   sumene4,
5454 c     &   dscp1,dscp2,sumene
5455 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5456         escloc = escloc + sumene
5457 c        write (2,*) "i",i," escloc",sumene,escloc
5458 #ifdef DEBUG
5459 C
5460 C This section to check the numerical derivatives of the energy of ith side
5461 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5462 C #define DEBUG in the code to turn it on.
5463 C
5464         write (2,*) "sumene               =",sumene
5465         aincr=1.0d-7
5466         xxsave=xx
5467         xx=xx+aincr
5468         write (2,*) xx,yy,zz
5469         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5470         de_dxx_num=(sumenep-sumene)/aincr
5471         xx=xxsave
5472         write (2,*) "xx+ sumene from enesc=",sumenep
5473         yysave=yy
5474         yy=yy+aincr
5475         write (2,*) xx,yy,zz
5476         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5477         de_dyy_num=(sumenep-sumene)/aincr
5478         yy=yysave
5479         write (2,*) "yy+ sumene from enesc=",sumenep
5480         zzsave=zz
5481         zz=zz+aincr
5482         write (2,*) xx,yy,zz
5483         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5484         de_dzz_num=(sumenep-sumene)/aincr
5485         zz=zzsave
5486         write (2,*) "zz+ sumene from enesc=",sumenep
5487         costsave=cost2tab(i+1)
5488         sintsave=sint2tab(i+1)
5489         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5490         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5491         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5492         de_dt_num=(sumenep-sumene)/aincr
5493         write (2,*) " t+ sumene from enesc=",sumenep
5494         cost2tab(i+1)=costsave
5495         sint2tab(i+1)=sintsave
5496 C End of diagnostics section.
5497 #endif
5498 C
5499 C Compute the gradient of esc
5500 C
5501         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5502         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5503         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5504         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5505         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5506         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5507         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5508         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5509         pom1=(sumene3*sint2tab(i+1)+sumene1)
5510      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5511         pom2=(sumene4*cost2tab(i+1)+sumene2)
5512      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5513         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5514         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5515      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5516      &  +x(40)*yy*zz
5517         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5518         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5519      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5520      &  +x(60)*yy*zz
5521         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5522      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5523      &        +(pom1+pom2)*pom_dx
5524 #ifdef DEBUG
5525         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5526 #endif
5527 C
5528         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5529         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5530      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5531      &  +x(40)*xx*zz
5532         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5533         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5534      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5535      &  +x(59)*zz**2 +x(60)*xx*zz
5536         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5537      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5538      &        +(pom1-pom2)*pom_dy
5539 #ifdef DEBUG
5540         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5541 #endif
5542 C
5543         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5544      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5545      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5546      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5547      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5548      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5549      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5550      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5551 #ifdef DEBUG
5552         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5553 #endif
5554 C
5555         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5556      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5557      &  +pom1*pom_dt1+pom2*pom_dt2
5558 #ifdef DEBUG
5559         write(2,*), "de_dt = ", de_dt,de_dt_num
5560 #endif
5561 c
5562 C
5563        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5564        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5565        cosfac2xx=cosfac2*xx
5566        sinfac2yy=sinfac2*yy
5567        do k = 1,3
5568          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5569      &      vbld_inv(i+1)
5570          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5571      &      vbld_inv(i)
5572          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5573          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5574 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5575 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5576 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5577 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5578          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5579          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5580          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5581          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5582          dZZ_Ci1(k)=0.0d0
5583          dZZ_Ci(k)=0.0d0
5584          do j=1,3
5585            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5586            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5587          enddo
5588
5589          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5590          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5591          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5592 c
5593          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5594          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5595        enddo
5596
5597        do k=1,3
5598          dXX_Ctab(k,i)=dXX_Ci(k)
5599          dXX_C1tab(k,i)=dXX_Ci1(k)
5600          dYY_Ctab(k,i)=dYY_Ci(k)
5601          dYY_C1tab(k,i)=dYY_Ci1(k)
5602          dZZ_Ctab(k,i)=dZZ_Ci(k)
5603          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5604          dXX_XYZtab(k,i)=dXX_XYZ(k)
5605          dYY_XYZtab(k,i)=dYY_XYZ(k)
5606          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5607        enddo
5608
5609        do k = 1,3
5610 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5611 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5612 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5613 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5614 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5615 c     &    dt_dci(k)
5616 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5617 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5618          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5619      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5620          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5621      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5622          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5623      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5624        enddo
5625 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5626 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5627
5628 C to check gradient call subroutine check_grad
5629
5630     1 continue
5631       enddo
5632       return
5633       end
5634 c------------------------------------------------------------------------------
5635       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5636       implicit none
5637       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5638      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5639       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5640      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5641      &   + x(10)*yy*zz
5642       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5643      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5644      & + x(20)*yy*zz
5645       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5646      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5647      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5648      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5649      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5650      &  +x(40)*xx*yy*zz
5651       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5652      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5653      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5654      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5655      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5656      &  +x(60)*xx*yy*zz
5657       dsc_i   = 0.743d0+x(61)
5658       dp2_i   = 1.9d0+x(62)
5659       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5660      &          *(xx*cost2+yy*sint2))
5661       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5662      &          *(xx*cost2-yy*sint2))
5663       s1=(1+x(63))/(0.1d0 + dscp1)
5664       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5665       s2=(1+x(65))/(0.1d0 + dscp2)
5666       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5667       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5668      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5669       enesc=sumene
5670       return
5671       end
5672 #endif
5673 c------------------------------------------------------------------------------
5674       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5675 C
5676 C This procedure calculates two-body contact function g(rij) and its derivative:
5677 C
5678 C           eps0ij                                     !       x < -1
5679 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5680 C            0                                         !       x > 1
5681 C
5682 C where x=(rij-r0ij)/delta
5683 C
5684 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5685 C
5686       implicit none
5687       double precision rij,r0ij,eps0ij,fcont,fprimcont
5688       double precision x,x2,x4,delta
5689 c     delta=0.02D0*r0ij
5690 c      delta=0.2D0*r0ij
5691       x=(rij-r0ij)/delta
5692       if (x.lt.-1.0D0) then
5693         fcont=eps0ij
5694         fprimcont=0.0D0
5695       else if (x.le.1.0D0) then
5696         x2=x*x
5697         x4=x2*x2
5698         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5699         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5700       else
5701         fcont=0.0D0
5702         fprimcont=0.0D0
5703       endif
5704       return
5705       end
5706 c------------------------------------------------------------------------------
5707       subroutine splinthet(theti,delta,ss,ssder)
5708       implicit real*8 (a-h,o-z)
5709       include 'DIMENSIONS'
5710       include 'COMMON.VAR'
5711       include 'COMMON.GEO'
5712       thetup=pi-delta
5713       thetlow=delta
5714       if (theti.gt.pipol) then
5715         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5716       else
5717         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5718         ssder=-ssder
5719       endif
5720       return
5721       end
5722 c------------------------------------------------------------------------------
5723       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5724       implicit none
5725       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5726       double precision ksi,ksi2,ksi3,a1,a2,a3
5727       a1=fprim0*delta/(f1-f0)
5728       a2=3.0d0-2.0d0*a1
5729       a3=a1-2.0d0
5730       ksi=(x-x0)/delta
5731       ksi2=ksi*ksi
5732       ksi3=ksi2*ksi
5733       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5734       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5735       return
5736       end
5737 c------------------------------------------------------------------------------
5738       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5739       implicit none
5740       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5741       double precision ksi,ksi2,ksi3,a1,a2,a3
5742       ksi=(x-x0)/delta
5743       ksi2=ksi*ksi
5744       ksi3=ksi2*ksi
5745       a1=fprim0x*delta
5746       a2=3*(f1x-f0x)-2*fprim0x*delta
5747       a3=fprim0x*delta-2*(f1x-f0x)
5748       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5749       return
5750       end
5751 C-----------------------------------------------------------------------------
5752 #ifdef CRYST_TOR
5753 C-----------------------------------------------------------------------------
5754       subroutine etor(etors,edihcnstr)
5755       implicit real*8 (a-h,o-z)
5756       include 'DIMENSIONS'
5757       include 'COMMON.VAR'
5758       include 'COMMON.GEO'
5759       include 'COMMON.LOCAL'
5760       include 'COMMON.TORSION'
5761       include 'COMMON.INTERACT'
5762       include 'COMMON.DERIV'
5763       include 'COMMON.CHAIN'
5764       include 'COMMON.NAMES'
5765       include 'COMMON.IOUNITS'
5766       include 'COMMON.FFIELD'
5767       include 'COMMON.TORCNSTR'
5768       include 'COMMON.CONTROL'
5769       logical lprn
5770 C Set lprn=.true. for debugging
5771       lprn=.false.
5772 c      lprn=.true.
5773       etors=0.0D0
5774       do i=iphi_start,iphi_end
5775       etors_ii=0.0D0
5776         itori=itortyp(itype(i-2))
5777         itori1=itortyp(itype(i-1))
5778         phii=phi(i)
5779         gloci=0.0D0
5780 C Proline-Proline pair is a special case...
5781         if (itori.eq.3 .and. itori1.eq.3) then
5782           if (phii.gt.-dwapi3) then
5783             cosphi=dcos(3*phii)
5784             fac=1.0D0/(1.0D0-cosphi)
5785             etorsi=v1(1,3,3)*fac
5786             etorsi=etorsi+etorsi
5787             etors=etors+etorsi-v1(1,3,3)
5788             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5789             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5790           endif
5791           do j=1,3
5792             v1ij=v1(j+1,itori,itori1)
5793             v2ij=v2(j+1,itori,itori1)
5794             cosphi=dcos(j*phii)
5795             sinphi=dsin(j*phii)
5796             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5797             if (energy_dec) etors_ii=etors_ii+
5798      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5799             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5800           enddo
5801         else
5802           do j=1,nterm_old
5803             v1ij=v1(j,itori,itori1)
5804             v2ij=v2(j,itori,itori1)
5805             cosphi=dcos(j*phii)
5806             sinphi=dsin(j*phii)
5807             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5808             if (energy_dec) etors_ii=etors_ii+
5809      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5810             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5811           enddo
5812         endif
5813         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5814      &        'etor',i,etors_ii
5815         if (lprn)
5816      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5817      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5818      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5819         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5820         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5821       enddo
5822 ! 6/20/98 - dihedral angle constraints
5823       edihcnstr=0.0d0
5824       do i=1,ndih_constr
5825         itori=idih_constr(i)
5826         phii=phi(itori)
5827         difi=phii-phi0(i)
5828         if (difi.gt.drange(i)) then
5829           difi=difi-drange(i)
5830           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5831           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5832         else if (difi.lt.-drange(i)) then
5833           difi=difi+drange(i)
5834           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5835           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5836         endif
5837 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5838 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5839       enddo
5840 !      write (iout,*) 'edihcnstr',edihcnstr
5841       return
5842       end
5843 c------------------------------------------------------------------------------
5844 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5845       subroutine e_modeller(ehomology_constr)
5846       ehomology_constr=0.0
5847       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5848       return
5849       end
5850 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5851
5852 c------------------------------------------------------------------------------
5853       subroutine etor_d(etors_d)
5854       etors_d=0.0d0
5855       return
5856       end
5857 c----------------------------------------------------------------------------
5858 #else
5859       subroutine etor(etors,edihcnstr)
5860       implicit real*8 (a-h,o-z)
5861       include 'DIMENSIONS'
5862       include 'COMMON.VAR'
5863       include 'COMMON.GEO'
5864       include 'COMMON.LOCAL'
5865       include 'COMMON.TORSION'
5866       include 'COMMON.INTERACT'
5867       include 'COMMON.DERIV'
5868       include 'COMMON.CHAIN'
5869       include 'COMMON.NAMES'
5870       include 'COMMON.IOUNITS'
5871       include 'COMMON.FFIELD'
5872       include 'COMMON.TORCNSTR'
5873       include 'COMMON.CONTROL'
5874       logical lprn
5875 C Set lprn=.true. for debugging
5876       lprn=.false.
5877 c     lprn=.true.
5878       etors=0.0D0
5879       do i=iphi_start,iphi_end
5880       etors_ii=0.0D0
5881         itori=itortyp(itype(i-2))
5882         itori1=itortyp(itype(i-1))
5883         phii=phi(i)
5884         gloci=0.0D0
5885 C Regular cosine and sine terms
5886         do j=1,nterm(itori,itori1)
5887           v1ij=v1(j,itori,itori1)
5888           v2ij=v2(j,itori,itori1)
5889           cosphi=dcos(j*phii)
5890           sinphi=dsin(j*phii)
5891           etors=etors+v1ij*cosphi+v2ij*sinphi
5892           if (energy_dec) etors_ii=etors_ii+
5893      &                v1ij*cosphi+v2ij*sinphi
5894           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5895         enddo
5896 C Lorentz terms
5897 C                         v1
5898 C  E = SUM ----------------------------------- - v1
5899 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5900 C
5901         cosphi=dcos(0.5d0*phii)
5902         sinphi=dsin(0.5d0*phii)
5903         do j=1,nlor(itori,itori1)
5904           vl1ij=vlor1(j,itori,itori1)
5905           vl2ij=vlor2(j,itori,itori1)
5906           vl3ij=vlor3(j,itori,itori1)
5907           pom=vl2ij*cosphi+vl3ij*sinphi
5908           pom1=1.0d0/(pom*pom+1.0d0)
5909           etors=etors+vl1ij*pom1
5910           if (energy_dec) etors_ii=etors_ii+
5911      &                vl1ij*pom1
5912           pom=-pom*pom1*pom1
5913           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5914         enddo
5915 C Subtract the constant term
5916         etors=etors-v0(itori,itori1)
5917           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5918      &         'etor',i,etors_ii-v0(itori,itori1)
5919         if (lprn)
5920      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5921      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5922      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5923         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5924 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5925       enddo
5926 ! 6/20/98 - dihedral angle constraints
5927       edihcnstr=0.0d0
5928 c      do i=1,ndih_constr
5929       do i=idihconstr_start,idihconstr_end
5930         itori=idih_constr(i)
5931         phii=phi(itori)
5932         difi=pinorm(phii-phi0(i))
5933         if (difi.gt.drange(i)) then
5934           difi=difi-drange(i)
5935           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5936           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5937         else if (difi.lt.-drange(i)) then
5938           difi=difi+drange(i)
5939           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5940           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5941         else
5942           difi=0.0
5943         endif
5944 c        write (iout,*) "gloci", gloc(i-3,icg)
5945 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5946 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5947 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5948       enddo
5949 cd       write (iout,*) 'edihcnstr',edihcnstr
5950       return
5951       end
5952 c----------------------------------------------------------------------------
5953 c MODELLER restraint function
5954       subroutine e_modeller(ehomology_constr)
5955       implicit real*8 (a-h,o-z)
5956       include 'DIMENSIONS'
5957
5958       integer nnn, i, j, k, ki, irec, l
5959       integer katy, odleglosci, test7
5960       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
5961       real*8 distance(max_template),distancek(max_template),
5962      &    min_odl,godl(max_template),dih_diff(max_template)
5963
5964       include 'COMMON.SBRIDGE'
5965       include 'COMMON.CHAIN'
5966       include 'COMMON.GEO'
5967       include 'COMMON.DERIV'
5968       include 'COMMON.LOCAL'
5969       include 'COMMON.INTERACT'
5970       include 'COMMON.VAR'
5971       include 'COMMON.IOUNITS'
5972       include 'COMMON.MD'
5973       include 'COMMON.CONTROL'
5974
5975
5976       do i=1,19
5977         distancek(i)=9999999.9
5978       enddo
5979
5980
5981       odleg=0.0d0
5982
5983 c Pseudo-energy and gradient from homology restraints (MODELLER-like
5984 c function)
5985 C AL 5/2/14 - Introduce list of restraints
5986       do ii = link_start_homo,link_end_homo
5987          i = ires_homo(ii)
5988          j = jres_homo(ii)
5989          dij=dist(i,j)
5990          do k=1,constr_homology
5991            distance(k)=odl(k,ii)-dij
5992            distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
5993          enddo
5994
5995          min_odl=minval(distancek)
5996 #ifdef DEBUG
5997          write (iout,*) "ij dij",i,j,dij
5998          write (iout,*) "distance",(distance(k),k=1,constr_homology)
5999          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6000          write (iout,* )"min_odl",min_odl
6001 #endif
6002          odleg2=0.0d0
6003          do k=1,constr_homology
6004 c Nie wiem po co to liczycie jeszcze raz!
6005 c            odleg3=-waga_dist*((distance(i,j,k)**2)/
6006 c     &              (2*(sigma_odl(i,j,k))**2))
6007             godl(k)=dexp(-distancek(k)+min_odl)
6008             odleg2=odleg2+godl(k)
6009
6010 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6011 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6012 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6013 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6014
6015          enddo
6016 #ifdef DEBUG
6017          write (iout,*) "godl",(godl(k),k=1,constr_homology)
6018          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2
6019 #endif
6020          odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6021 c Gradient
6022          sum_godl=odleg2
6023          sum_sgodl=0.0
6024          do k=1,constr_homology
6025 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6026 c     &           *waga_dist)+min_odl
6027            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6028            sum_sgodl=sum_sgodl+sgodl
6029
6030 c            sgodl2=sgodl2+sgodl
6031 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6032 c      write(iout,*) "constr_homology=",constr_homology
6033 c      write(iout,*) i, j, k, "TEST K"
6034          enddo
6035
6036          grad_odl3=sum_sgodl/(sum_godl*dij)
6037
6038
6039 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6040 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6041 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6042
6043 ccc      write(iout,*) godl, sgodl, grad_odl3
6044
6045 c          grad_odl=grad_odl+grad_odl3
6046
6047          do jik=1,3
6048             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
6049 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6050 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6051 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6052             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
6053             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
6054 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6055 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6056
6057          enddo
6058 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
6059 ccc     & dLOG(odleg2),"-odleg=", -odleg
6060
6061       enddo ! ii
6062 c Pseudo-energy and gradient from dihedral-angle restraints from
6063 c homology templates
6064 c      write (iout,*) "End of distance loop"
6065 c      call flush(iout)
6066       kat=0.0d0
6067 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6068       do i=idihconstr_start_homo,idihconstr_end_homo
6069         kat2=0.0d0
6070 c        betai=beta(i,i+1,i+2,i+3)
6071         betai = phi(i+3)
6072         do k=1,constr_homology
6073           dih_diff(k)=pinorm(dih(k,i)-betai)
6074 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6075 c     &                                   -(6.28318-dih_diff(i,k))
6076 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6077 c     &                                   6.28318+dih_diff(i,k)
6078
6079           kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
6080           gdih(k)=dexp(kat3)
6081           kat2=kat2+gdih(k)
6082 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
6083 c          write(*,*)""
6084         enddo
6085 #ifdef DEBUG
6086         write (iout,*) "i",i," betai",betai," kat2",kat2
6087         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6088 #endif
6089         if (kat2.le.1.0d-14) cycle
6090         kat=kat-dLOG(kat2/constr_homology)
6091
6092 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6093 ccc     & dLOG(kat2), "-kat=", -kat
6094
6095 c ----------------------------------------------------------------------
6096 c Gradient
6097 c ----------------------------------------------------------------------
6098
6099         sum_gdih=kat2
6100         sum_sgdih=0.0
6101         do k=1,constr_homology
6102           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
6103           sum_sgdih=sum_sgdih+sgdih
6104         enddo
6105         grad_dih3=sum_sgdih/sum_gdih
6106
6107 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6108 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6109 ccc     & gloc(nphi+i-3,icg)
6110         gloc(i,icg)=gloc(i,icg)+grad_dih3
6111 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6112 ccc     & gloc(nphi+i-3,icg)
6113
6114       enddo
6115
6116
6117 c Total energy from homology restraints
6118 #ifdef DEBUG
6119       write (iout,*) "odleg",odleg," kat",kat
6120 #endif
6121       ehomology_constr=odleg+kat
6122       return
6123
6124   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6125   747 format(a12,i4,i4,i4,f8.3,f8.3)
6126   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6127   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6128   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6129      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6130       end
6131
6132 c------------------------------------------------------------------------------
6133       subroutine etor_d(etors_d)
6134 C 6/23/01 Compute double torsional energy
6135       implicit real*8 (a-h,o-z)
6136       include 'DIMENSIONS'
6137       include 'COMMON.VAR'
6138       include 'COMMON.GEO'
6139       include 'COMMON.LOCAL'
6140       include 'COMMON.TORSION'
6141       include 'COMMON.INTERACT'
6142       include 'COMMON.DERIV'
6143       include 'COMMON.CHAIN'
6144       include 'COMMON.NAMES'
6145       include 'COMMON.IOUNITS'
6146       include 'COMMON.FFIELD'
6147       include 'COMMON.TORCNSTR'
6148       logical lprn
6149 C Set lprn=.true. for debugging
6150       lprn=.false.
6151 c     lprn=.true.
6152       etors_d=0.0D0
6153       do i=iphid_start,iphid_end
6154         itori=itortyp(itype(i-2))
6155         itori1=itortyp(itype(i-1))
6156         itori2=itortyp(itype(i))
6157         phii=phi(i)
6158         phii1=phi(i+1)
6159         gloci1=0.0D0
6160         gloci2=0.0D0
6161         do j=1,ntermd_1(itori,itori1,itori2)
6162           v1cij=v1c(1,j,itori,itori1,itori2)
6163           v1sij=v1s(1,j,itori,itori1,itori2)
6164           v2cij=v1c(2,j,itori,itori1,itori2)
6165           v2sij=v1s(2,j,itori,itori1,itori2)
6166           cosphi1=dcos(j*phii)
6167           sinphi1=dsin(j*phii)
6168           cosphi2=dcos(j*phii1)
6169           sinphi2=dsin(j*phii1)
6170           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6171      &     v2cij*cosphi2+v2sij*sinphi2
6172           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6173           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6174         enddo
6175         do k=2,ntermd_2(itori,itori1,itori2)
6176           do l=1,k-1
6177             v1cdij = v2c(k,l,itori,itori1,itori2)
6178             v2cdij = v2c(l,k,itori,itori1,itori2)
6179             v1sdij = v2s(k,l,itori,itori1,itori2)
6180             v2sdij = v2s(l,k,itori,itori1,itori2)
6181             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6182             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6183             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6184             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6185             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6186      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6187             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6188      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6189             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6190      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6191           enddo
6192         enddo
6193         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6194         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6195 c        write (iout,*) "gloci", gloc(i-3,icg)
6196       enddo
6197       return
6198       end
6199 #endif
6200 c------------------------------------------------------------------------------
6201       subroutine eback_sc_corr(esccor)
6202 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6203 c        conformational states; temporarily implemented as differences
6204 c        between UNRES torsional potentials (dependent on three types of
6205 c        residues) and the torsional potentials dependent on all 20 types
6206 c        of residues computed from AM1  energy surfaces of terminally-blocked
6207 c        amino-acid residues.
6208       implicit real*8 (a-h,o-z)
6209       include 'DIMENSIONS'
6210       include 'COMMON.VAR'
6211       include 'COMMON.GEO'
6212       include 'COMMON.LOCAL'
6213       include 'COMMON.TORSION'
6214       include 'COMMON.SCCOR'
6215       include 'COMMON.INTERACT'
6216       include 'COMMON.DERIV'
6217       include 'COMMON.CHAIN'
6218       include 'COMMON.NAMES'
6219       include 'COMMON.IOUNITS'
6220       include 'COMMON.FFIELD'
6221       include 'COMMON.CONTROL'
6222       logical lprn
6223 C Set lprn=.true. for debugging
6224       lprn=.false.
6225 c      lprn=.true.
6226 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6227       esccor=0.0D0
6228       do i=itau_start,itau_end
6229         esccor_ii=0.0D0
6230         isccori=isccortyp(itype(i-2))
6231         isccori1=isccortyp(itype(i-1))
6232         phii=phi(i)
6233 cccc  Added 9 May 2012
6234 cc Tauangle is torsional engle depending on the value of first digit
6235 c(see comment below)
6236 cc Omicron is flat angle depending on the value of first digit
6237 c(see comment below)
6238
6239
6240         do intertyp=1,3 !intertyp
6241 cc Added 09 May 2012 (Adasko)
6242 cc  Intertyp means interaction type of backbone mainchain correlation:
6243 c   1 = SC...Ca...Ca...Ca
6244 c   2 = Ca...Ca...Ca...SC
6245 c   3 = SC...Ca...Ca...SCi
6246         gloci=0.0D0
6247         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6248      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6249      &      (itype(i-1).eq.21)))
6250      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6251      &     .or.(itype(i-2).eq.21)))
6252      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6253      &      (itype(i-1).eq.21)))) cycle
6254         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6255         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6256      & cycle
6257         do j=1,nterm_sccor(isccori,isccori1)
6258           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6259           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6260           cosphi=dcos(j*tauangle(intertyp,i))
6261           sinphi=dsin(j*tauangle(intertyp,i))
6262           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6263           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6264         enddo
6265         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6266 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6267 c     &gloc_sc(intertyp,i-3,icg)
6268         if (lprn)
6269      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6270      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6271      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6272      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6273         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6274        enddo !intertyp
6275       enddo
6276 c        do i=1,nres
6277 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6278 c        enddo
6279       return
6280       end
6281 c----------------------------------------------------------------------------
6282       subroutine multibody(ecorr)
6283 C This subroutine calculates multi-body contributions to energy following
6284 C the idea of Skolnick et al. If side chains I and J make a contact and
6285 C at the same time side chains I+1 and J+1 make a contact, an extra
6286 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6287       implicit real*8 (a-h,o-z)
6288       include 'DIMENSIONS'
6289       include 'COMMON.IOUNITS'
6290       include 'COMMON.DERIV'
6291       include 'COMMON.INTERACT'
6292       include 'COMMON.CONTACTS'
6293       double precision gx(3),gx1(3)
6294       logical lprn
6295
6296 C Set lprn=.true. for debugging
6297       lprn=.false.
6298
6299       if (lprn) then
6300         write (iout,'(a)') 'Contact function values:'
6301         do i=nnt,nct-2
6302           write (iout,'(i2,20(1x,i2,f10.5))')
6303      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6304         enddo
6305       endif
6306       ecorr=0.0D0
6307       do i=nnt,nct
6308         do j=1,3
6309           gradcorr(j,i)=0.0D0
6310           gradxorr(j,i)=0.0D0
6311         enddo
6312       enddo
6313       do i=nnt,nct-2
6314
6315         DO ISHIFT = 3,4
6316
6317         i1=i+ishift
6318         num_conti=num_cont(i)
6319         num_conti1=num_cont(i1)
6320         do jj=1,num_conti
6321           j=jcont(jj,i)
6322           do kk=1,num_conti1
6323             j1=jcont(kk,i1)
6324             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6325 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6326 cd   &                   ' ishift=',ishift
6327 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6328 C The system gains extra energy.
6329               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6330             endif   ! j1==j+-ishift
6331           enddo     ! kk
6332         enddo       ! jj
6333
6334         ENDDO ! ISHIFT
6335
6336       enddo         ! i
6337       return
6338       end
6339 c------------------------------------------------------------------------------
6340       double precision function esccorr(i,j,k,l,jj,kk)
6341       implicit real*8 (a-h,o-z)
6342       include 'DIMENSIONS'
6343       include 'COMMON.IOUNITS'
6344       include 'COMMON.DERIV'
6345       include 'COMMON.INTERACT'
6346       include 'COMMON.CONTACTS'
6347       double precision gx(3),gx1(3)
6348       logical lprn
6349       lprn=.false.
6350       eij=facont(jj,i)
6351       ekl=facont(kk,k)
6352 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6353 C Calculate the multi-body contribution to energy.
6354 C Calculate multi-body contributions to the gradient.
6355 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6356 cd   & k,l,(gacont(m,kk,k),m=1,3)
6357       do m=1,3
6358         gx(m) =ekl*gacont(m,jj,i)
6359         gx1(m)=eij*gacont(m,kk,k)
6360         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6361         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6362         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6363         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6364       enddo
6365       do m=i,j-1
6366         do ll=1,3
6367           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6368         enddo
6369       enddo
6370       do m=k,l-1
6371         do ll=1,3
6372           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6373         enddo
6374       enddo
6375       esccorr=-eij*ekl
6376       return
6377       end
6378 c------------------------------------------------------------------------------
6379       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6380 C This subroutine calculates multi-body contributions to hydrogen-bonding
6381       implicit real*8 (a-h,o-z)
6382       include 'DIMENSIONS'
6383       include 'COMMON.IOUNITS'
6384 #ifdef MPI
6385       include "mpif.h"
6386       parameter (max_cont=maxconts)
6387       parameter (max_dim=26)
6388       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6389       double precision zapas(max_dim,maxconts,max_fg_procs),
6390      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6391       common /przechowalnia/ zapas
6392       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6393      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6394 #endif
6395       include 'COMMON.SETUP'
6396       include 'COMMON.FFIELD'
6397       include 'COMMON.DERIV'
6398       include 'COMMON.INTERACT'
6399       include 'COMMON.CONTACTS'
6400       include 'COMMON.CONTROL'
6401       include 'COMMON.LOCAL'
6402       double precision gx(3),gx1(3),time00
6403       logical lprn,ldone
6404
6405 C Set lprn=.true. for debugging
6406       lprn=.false.
6407 #ifdef MPI
6408       n_corr=0
6409       n_corr1=0
6410       if (nfgtasks.le.1) goto 30
6411       if (lprn) then
6412         write (iout,'(a)') 'Contact function values before RECEIVE:'
6413         do i=nnt,nct-2
6414           write (iout,'(2i3,50(1x,i2,f5.2))')
6415      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6416      &    j=1,num_cont_hb(i))
6417         enddo
6418       endif
6419       call flush(iout)
6420       do i=1,ntask_cont_from
6421         ncont_recv(i)=0
6422       enddo
6423       do i=1,ntask_cont_to
6424         ncont_sent(i)=0
6425       enddo
6426 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6427 c     & ntask_cont_to
6428 C Make the list of contacts to send to send to other procesors
6429 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6430 c      call flush(iout)
6431       do i=iturn3_start,iturn3_end
6432 c        write (iout,*) "make contact list turn3",i," num_cont",
6433 c     &    num_cont_hb(i)
6434         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6435       enddo
6436       do i=iturn4_start,iturn4_end
6437 c        write (iout,*) "make contact list turn4",i," num_cont",
6438 c     &   num_cont_hb(i)
6439         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6440       enddo
6441       do ii=1,nat_sent
6442         i=iat_sent(ii)
6443 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6444 c     &    num_cont_hb(i)
6445         do j=1,num_cont_hb(i)
6446         do k=1,4
6447           jjc=jcont_hb(j,i)
6448           iproc=iint_sent_local(k,jjc,ii)
6449 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6450           if (iproc.gt.0) then
6451             ncont_sent(iproc)=ncont_sent(iproc)+1
6452             nn=ncont_sent(iproc)
6453             zapas(1,nn,iproc)=i
6454             zapas(2,nn,iproc)=jjc
6455             zapas(3,nn,iproc)=facont_hb(j,i)
6456             zapas(4,nn,iproc)=ees0p(j,i)
6457             zapas(5,nn,iproc)=ees0m(j,i)
6458             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6459             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6460             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6461             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6462             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6463             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6464             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6465             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6466             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6467             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6468             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6469             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6470             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6471             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6472             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6473             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6474             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6475             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6476             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6477             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6478             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6479           endif
6480         enddo
6481         enddo
6482       enddo
6483       if (lprn) then
6484       write (iout,*)
6485      &  "Numbers of contacts to be sent to other processors",
6486      &  (ncont_sent(i),i=1,ntask_cont_to)
6487       write (iout,*) "Contacts sent"
6488       do ii=1,ntask_cont_to
6489         nn=ncont_sent(ii)
6490         iproc=itask_cont_to(ii)
6491         write (iout,*) nn," contacts to processor",iproc,
6492      &   " of CONT_TO_COMM group"
6493         do i=1,nn
6494           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6495         enddo
6496       enddo
6497       call flush(iout)
6498       endif
6499       CorrelType=477
6500       CorrelID=fg_rank+1
6501       CorrelType1=478
6502       CorrelID1=nfgtasks+fg_rank+1
6503       ireq=0
6504 C Receive the numbers of needed contacts from other processors
6505       do ii=1,ntask_cont_from
6506         iproc=itask_cont_from(ii)
6507         ireq=ireq+1
6508         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6509      &    FG_COMM,req(ireq),IERR)
6510       enddo
6511 c      write (iout,*) "IRECV ended"
6512 c      call flush(iout)
6513 C Send the number of contacts needed by other processors
6514       do ii=1,ntask_cont_to
6515         iproc=itask_cont_to(ii)
6516         ireq=ireq+1
6517         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6518      &    FG_COMM,req(ireq),IERR)
6519       enddo
6520 c      write (iout,*) "ISEND ended"
6521 c      write (iout,*) "number of requests (nn)",ireq
6522       call flush(iout)
6523       if (ireq.gt.0)
6524      &  call MPI_Waitall(ireq,req,status_array,ierr)
6525 c      write (iout,*)
6526 c     &  "Numbers of contacts to be received from other processors",
6527 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6528 c      call flush(iout)
6529 C Receive contacts
6530       ireq=0
6531       do ii=1,ntask_cont_from
6532         iproc=itask_cont_from(ii)
6533         nn=ncont_recv(ii)
6534 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6535 c     &   " of CONT_TO_COMM group"
6536         call flush(iout)
6537         if (nn.gt.0) then
6538           ireq=ireq+1
6539           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6540      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6541 c          write (iout,*) "ireq,req",ireq,req(ireq)
6542         endif
6543       enddo
6544 C Send the contacts to processors that need them
6545       do ii=1,ntask_cont_to
6546         iproc=itask_cont_to(ii)
6547         nn=ncont_sent(ii)
6548 c        write (iout,*) nn," contacts to processor",iproc,
6549 c     &   " of CONT_TO_COMM group"
6550         if (nn.gt.0) then
6551           ireq=ireq+1
6552           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6553      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6554 c          write (iout,*) "ireq,req",ireq,req(ireq)
6555 c          do i=1,nn
6556 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6557 c          enddo
6558         endif
6559       enddo
6560 c      write (iout,*) "number of requests (contacts)",ireq
6561 c      write (iout,*) "req",(req(i),i=1,4)
6562 c      call flush(iout)
6563       if (ireq.gt.0)
6564      & call MPI_Waitall(ireq,req,status_array,ierr)
6565       do iii=1,ntask_cont_from
6566         iproc=itask_cont_from(iii)
6567         nn=ncont_recv(iii)
6568         if (lprn) then
6569         write (iout,*) "Received",nn," contacts from processor",iproc,
6570      &   " of CONT_FROM_COMM group"
6571         call flush(iout)
6572         do i=1,nn
6573           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6574         enddo
6575         call flush(iout)
6576         endif
6577         do i=1,nn
6578           ii=zapas_recv(1,i,iii)
6579 c Flag the received contacts to prevent double-counting
6580           jj=-zapas_recv(2,i,iii)
6581 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6582 c          call flush(iout)
6583           nnn=num_cont_hb(ii)+1
6584           num_cont_hb(ii)=nnn
6585           jcont_hb(nnn,ii)=jj
6586           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6587           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6588           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6589           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6590           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6591           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6592           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6593           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6594           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6595           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6596           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6597           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6598           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6599           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6600           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6601           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6602           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6603           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6604           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6605           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6606           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6607           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6608           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6609           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6610         enddo
6611       enddo
6612       call flush(iout)
6613       if (lprn) then
6614         write (iout,'(a)') 'Contact function values after receive:'
6615         do i=nnt,nct-2
6616           write (iout,'(2i3,50(1x,i3,f5.2))')
6617      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6618      &    j=1,num_cont_hb(i))
6619         enddo
6620         call flush(iout)
6621       endif
6622    30 continue
6623 #endif
6624       if (lprn) then
6625         write (iout,'(a)') 'Contact function values:'
6626         do i=nnt,nct-2
6627           write (iout,'(2i3,50(1x,i3,f5.2))')
6628      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6629      &    j=1,num_cont_hb(i))
6630         enddo
6631       endif
6632       ecorr=0.0D0
6633 C Remove the loop below after debugging !!!
6634       do i=nnt,nct
6635         do j=1,3
6636           gradcorr(j,i)=0.0D0
6637           gradxorr(j,i)=0.0D0
6638         enddo
6639       enddo
6640 C Calculate the local-electrostatic correlation terms
6641       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6642         i1=i+1
6643         num_conti=num_cont_hb(i)
6644         num_conti1=num_cont_hb(i+1)
6645         do jj=1,num_conti
6646           j=jcont_hb(jj,i)
6647           jp=iabs(j)
6648           do kk=1,num_conti1
6649             j1=jcont_hb(kk,i1)
6650             jp1=iabs(j1)
6651 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6652 c     &         ' jj=',jj,' kk=',kk
6653             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6654      &          .or. j.lt.0 .and. j1.gt.0) .and.
6655      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6656 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6657 C The system gains extra energy.
6658               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6659               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6660      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6661               n_corr=n_corr+1
6662             else if (j1.eq.j) then
6663 C Contacts I-J and I-(J+1) occur simultaneously.
6664 C The system loses extra energy.
6665 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6666             endif
6667           enddo ! kk
6668           do kk=1,num_conti
6669             j1=jcont_hb(kk,i)
6670 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6671 c    &         ' jj=',jj,' kk=',kk
6672             if (j1.eq.j+1) then
6673 C Contacts I-J and (I+1)-J occur simultaneously.
6674 C The system loses extra energy.
6675 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6676             endif ! j1==j+1
6677           enddo ! kk
6678         enddo ! jj
6679       enddo ! i
6680       return
6681       end
6682 c------------------------------------------------------------------------------
6683       subroutine add_hb_contact(ii,jj,itask)
6684       implicit real*8 (a-h,o-z)
6685       include "DIMENSIONS"
6686       include "COMMON.IOUNITS"
6687       integer max_cont
6688       integer max_dim
6689       parameter (max_cont=maxconts)
6690       parameter (max_dim=26)
6691       include "COMMON.CONTACTS"
6692       double precision zapas(max_dim,maxconts,max_fg_procs),
6693      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6694       common /przechowalnia/ zapas
6695       integer i,j,ii,jj,iproc,itask(4),nn
6696 c      write (iout,*) "itask",itask
6697       do i=1,2
6698         iproc=itask(i)
6699         if (iproc.gt.0) then
6700           do j=1,num_cont_hb(ii)
6701             jjc=jcont_hb(j,ii)
6702 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6703             if (jjc.eq.jj) then
6704               ncont_sent(iproc)=ncont_sent(iproc)+1
6705               nn=ncont_sent(iproc)
6706               zapas(1,nn,iproc)=ii
6707               zapas(2,nn,iproc)=jjc
6708               zapas(3,nn,iproc)=facont_hb(j,ii)
6709               zapas(4,nn,iproc)=ees0p(j,ii)
6710               zapas(5,nn,iproc)=ees0m(j,ii)
6711               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6712               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6713               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6714               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6715               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6716               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6717               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6718               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6719               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6720               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6721               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6722               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6723               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6724               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6725               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6726               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6727               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6728               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6729               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6730               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6731               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6732               exit
6733             endif
6734           enddo
6735         endif
6736       enddo
6737       return
6738       end
6739 c------------------------------------------------------------------------------
6740       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6741      &  n_corr1)
6742 C This subroutine calculates multi-body contributions to hydrogen-bonding
6743       implicit real*8 (a-h,o-z)
6744       include 'DIMENSIONS'
6745       include 'COMMON.IOUNITS'
6746 #ifdef MPI
6747       include "mpif.h"
6748       parameter (max_cont=maxconts)
6749       parameter (max_dim=70)
6750       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6751       double precision zapas(max_dim,maxconts,max_fg_procs),
6752      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6753       common /przechowalnia/ zapas
6754       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6755      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6756 #endif
6757       include 'COMMON.SETUP'
6758       include 'COMMON.FFIELD'
6759       include 'COMMON.DERIV'
6760       include 'COMMON.LOCAL'
6761       include 'COMMON.INTERACT'
6762       include 'COMMON.CONTACTS'
6763       include 'COMMON.CHAIN'
6764       include 'COMMON.CONTROL'
6765       double precision gx(3),gx1(3)
6766       integer num_cont_hb_old(maxres)
6767       logical lprn,ldone
6768       double precision eello4,eello5,eelo6,eello_turn6
6769       external eello4,eello5,eello6,eello_turn6
6770 C Set lprn=.true. for debugging
6771       lprn=.false.
6772       eturn6=0.0d0
6773 #ifdef MPI
6774       do i=1,nres
6775         num_cont_hb_old(i)=num_cont_hb(i)
6776       enddo
6777       n_corr=0
6778       n_corr1=0
6779       if (nfgtasks.le.1) goto 30
6780       if (lprn) then
6781         write (iout,'(a)') 'Contact function values before RECEIVE:'
6782         do i=nnt,nct-2
6783           write (iout,'(2i3,50(1x,i2,f5.2))')
6784      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6785      &    j=1,num_cont_hb(i))
6786         enddo
6787       endif
6788       call flush(iout)
6789       do i=1,ntask_cont_from
6790         ncont_recv(i)=0
6791       enddo
6792       do i=1,ntask_cont_to
6793         ncont_sent(i)=0
6794       enddo
6795 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6796 c     & ntask_cont_to
6797 C Make the list of contacts to send to send to other procesors
6798       do i=iturn3_start,iturn3_end
6799 c        write (iout,*) "make contact list turn3",i," num_cont",
6800 c     &    num_cont_hb(i)
6801         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6802       enddo
6803       do i=iturn4_start,iturn4_end
6804 c        write (iout,*) "make contact list turn4",i," num_cont",
6805 c     &   num_cont_hb(i)
6806         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6807       enddo
6808       do ii=1,nat_sent
6809         i=iat_sent(ii)
6810 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6811 c     &    num_cont_hb(i)
6812         do j=1,num_cont_hb(i)
6813         do k=1,4
6814           jjc=jcont_hb(j,i)
6815           iproc=iint_sent_local(k,jjc,ii)
6816 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6817           if (iproc.ne.0) then
6818             ncont_sent(iproc)=ncont_sent(iproc)+1
6819             nn=ncont_sent(iproc)
6820             zapas(1,nn,iproc)=i
6821             zapas(2,nn,iproc)=jjc
6822             zapas(3,nn,iproc)=d_cont(j,i)
6823             ind=3
6824             do kk=1,3
6825               ind=ind+1
6826               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6827             enddo
6828             do kk=1,2
6829               do ll=1,2
6830                 ind=ind+1
6831                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6832               enddo
6833             enddo
6834             do jj=1,5
6835               do kk=1,3
6836                 do ll=1,2
6837                   do mm=1,2
6838                     ind=ind+1
6839                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6840                   enddo
6841                 enddo
6842               enddo
6843             enddo
6844           endif
6845         enddo
6846         enddo
6847       enddo
6848       if (lprn) then
6849       write (iout,*)
6850      &  "Numbers of contacts to be sent to other processors",
6851      &  (ncont_sent(i),i=1,ntask_cont_to)
6852       write (iout,*) "Contacts sent"
6853       do ii=1,ntask_cont_to
6854         nn=ncont_sent(ii)
6855         iproc=itask_cont_to(ii)
6856         write (iout,*) nn," contacts to processor",iproc,
6857      &   " of CONT_TO_COMM group"
6858         do i=1,nn
6859           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6860         enddo
6861       enddo
6862       call flush(iout)
6863       endif
6864       CorrelType=477
6865       CorrelID=fg_rank+1
6866       CorrelType1=478
6867       CorrelID1=nfgtasks+fg_rank+1
6868       ireq=0
6869 C Receive the numbers of needed contacts from other processors
6870       do ii=1,ntask_cont_from
6871         iproc=itask_cont_from(ii)
6872         ireq=ireq+1
6873         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6874      &    FG_COMM,req(ireq),IERR)
6875       enddo
6876 c      write (iout,*) "IRECV ended"
6877 c      call flush(iout)
6878 C Send the number of contacts needed by other processors
6879       do ii=1,ntask_cont_to
6880         iproc=itask_cont_to(ii)
6881         ireq=ireq+1
6882         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6883      &    FG_COMM,req(ireq),IERR)
6884       enddo
6885 c      write (iout,*) "ISEND ended"
6886 c      write (iout,*) "number of requests (nn)",ireq
6887       call flush(iout)
6888       if (ireq.gt.0)
6889      &  call MPI_Waitall(ireq,req,status_array,ierr)
6890 c      write (iout,*)
6891 c     &  "Numbers of contacts to be received from other processors",
6892 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6893 c      call flush(iout)
6894 C Receive contacts
6895       ireq=0
6896       do ii=1,ntask_cont_from
6897         iproc=itask_cont_from(ii)
6898         nn=ncont_recv(ii)
6899 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6900 c     &   " of CONT_TO_COMM group"
6901         call flush(iout)
6902         if (nn.gt.0) then
6903           ireq=ireq+1
6904           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6905      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6906 c          write (iout,*) "ireq,req",ireq,req(ireq)
6907         endif
6908       enddo
6909 C Send the contacts to processors that need them
6910       do ii=1,ntask_cont_to
6911         iproc=itask_cont_to(ii)
6912         nn=ncont_sent(ii)
6913 c        write (iout,*) nn," contacts to processor",iproc,
6914 c     &   " of CONT_TO_COMM group"
6915         if (nn.gt.0) then
6916           ireq=ireq+1
6917           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6918      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6919 c          write (iout,*) "ireq,req",ireq,req(ireq)
6920 c          do i=1,nn
6921 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6922 c          enddo
6923         endif
6924       enddo
6925 c      write (iout,*) "number of requests (contacts)",ireq
6926 c      write (iout,*) "req",(req(i),i=1,4)
6927 c      call flush(iout)
6928       if (ireq.gt.0)
6929      & call MPI_Waitall(ireq,req,status_array,ierr)
6930       do iii=1,ntask_cont_from
6931         iproc=itask_cont_from(iii)
6932         nn=ncont_recv(iii)
6933         if (lprn) then
6934         write (iout,*) "Received",nn," contacts from processor",iproc,
6935      &   " of CONT_FROM_COMM group"
6936         call flush(iout)
6937         do i=1,nn
6938           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6939         enddo
6940         call flush(iout)
6941         endif
6942         do i=1,nn
6943           ii=zapas_recv(1,i,iii)
6944 c Flag the received contacts to prevent double-counting
6945           jj=-zapas_recv(2,i,iii)
6946 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6947 c          call flush(iout)
6948           nnn=num_cont_hb(ii)+1
6949           num_cont_hb(ii)=nnn
6950           jcont_hb(nnn,ii)=jj
6951           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6952           ind=3
6953           do kk=1,3
6954             ind=ind+1
6955             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6956           enddo
6957           do kk=1,2
6958             do ll=1,2
6959               ind=ind+1
6960               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6961             enddo
6962           enddo
6963           do jj=1,5
6964             do kk=1,3
6965               do ll=1,2
6966                 do mm=1,2
6967                   ind=ind+1
6968                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6969                 enddo
6970               enddo
6971             enddo
6972           enddo
6973         enddo
6974       enddo
6975       call flush(iout)
6976       if (lprn) then
6977         write (iout,'(a)') 'Contact function values after receive:'
6978         do i=nnt,nct-2
6979           write (iout,'(2i3,50(1x,i3,5f6.3))')
6980      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6981      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6982         enddo
6983         call flush(iout)
6984       endif
6985    30 continue
6986 #endif
6987       if (lprn) then
6988         write (iout,'(a)') 'Contact function values:'
6989         do i=nnt,nct-2
6990           write (iout,'(2i3,50(1x,i2,5f6.3))')
6991      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6992      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6993         enddo
6994       endif
6995       ecorr=0.0D0
6996       ecorr5=0.0d0
6997       ecorr6=0.0d0
6998 C Remove the loop below after debugging !!!
6999       do i=nnt,nct
7000         do j=1,3
7001           gradcorr(j,i)=0.0D0
7002           gradxorr(j,i)=0.0D0
7003         enddo
7004       enddo
7005 C Calculate the dipole-dipole interaction energies
7006       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7007       do i=iatel_s,iatel_e+1
7008         num_conti=num_cont_hb(i)
7009         do jj=1,num_conti
7010           j=jcont_hb(jj,i)
7011 #ifdef MOMENT
7012           call dipole(i,j,jj)
7013 #endif
7014         enddo
7015       enddo
7016       endif
7017 C Calculate the local-electrostatic correlation terms
7018 c                write (iout,*) "gradcorr5 in eello5 before loop"
7019 c                do iii=1,nres
7020 c                  write (iout,'(i5,3f10.5)')
7021 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7022 c                enddo
7023       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7024 c        write (iout,*) "corr loop i",i
7025         i1=i+1
7026         num_conti=num_cont_hb(i)
7027         num_conti1=num_cont_hb(i+1)
7028         do jj=1,num_conti
7029           j=jcont_hb(jj,i)
7030           jp=iabs(j)
7031           do kk=1,num_conti1
7032             j1=jcont_hb(kk,i1)
7033             jp1=iabs(j1)
7034 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7035 c     &         ' jj=',jj,' kk=',kk
7036 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7037             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7038      &          .or. j.lt.0 .and. j1.gt.0) .and.
7039      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7040 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7041 C The system gains extra energy.
7042               n_corr=n_corr+1
7043               sqd1=dsqrt(d_cont(jj,i))
7044               sqd2=dsqrt(d_cont(kk,i1))
7045               sred_geom = sqd1*sqd2
7046               IF (sred_geom.lt.cutoff_corr) THEN
7047                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7048      &            ekont,fprimcont)
7049 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7050 cd     &         ' jj=',jj,' kk=',kk
7051                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7052                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7053                 do l=1,3
7054                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7055                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7056                 enddo
7057                 n_corr1=n_corr1+1
7058 cd               write (iout,*) 'sred_geom=',sred_geom,
7059 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7060 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7061 cd               write (iout,*) "g_contij",g_contij
7062 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7063 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7064                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7065                 if (wcorr4.gt.0.0d0)
7066      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7067                   if (energy_dec.and.wcorr4.gt.0.0d0)
7068      1                 write (iout,'(a6,4i5,0pf7.3)')
7069      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7070 c                write (iout,*) "gradcorr5 before eello5"
7071 c                do iii=1,nres
7072 c                  write (iout,'(i5,3f10.5)')
7073 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7074 c                enddo
7075                 if (wcorr5.gt.0.0d0)
7076      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7077 c                write (iout,*) "gradcorr5 after eello5"
7078 c                do iii=1,nres
7079 c                  write (iout,'(i5,3f10.5)')
7080 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7081 c                enddo
7082                   if (energy_dec.and.wcorr5.gt.0.0d0)
7083      1                 write (iout,'(a6,4i5,0pf7.3)')
7084      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7085 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7086 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7087                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7088      &               .or. wturn6.eq.0.0d0))then
7089 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7090                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7091                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7092      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7093 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7094 cd     &            'ecorr6=',ecorr6
7095 cd                write (iout,'(4e15.5)') sred_geom,
7096 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7097 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7098 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7099                 else if (wturn6.gt.0.0d0
7100      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7101 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7102                   eturn6=eturn6+eello_turn6(i,jj,kk)
7103                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7104      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7105 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7106                 endif
7107               ENDIF
7108 1111          continue
7109             endif
7110           enddo ! kk
7111         enddo ! jj
7112       enddo ! i
7113       do i=1,nres
7114         num_cont_hb(i)=num_cont_hb_old(i)
7115       enddo
7116 c                write (iout,*) "gradcorr5 in eello5"
7117 c                do iii=1,nres
7118 c                  write (iout,'(i5,3f10.5)')
7119 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7120 c                enddo
7121       return
7122       end
7123 c------------------------------------------------------------------------------
7124       subroutine add_hb_contact_eello(ii,jj,itask)
7125       implicit real*8 (a-h,o-z)
7126       include "DIMENSIONS"
7127       include "COMMON.IOUNITS"
7128       integer max_cont
7129       integer max_dim
7130       parameter (max_cont=maxconts)
7131       parameter (max_dim=70)
7132       include "COMMON.CONTACTS"
7133       double precision zapas(max_dim,maxconts,max_fg_procs),
7134      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7135       common /przechowalnia/ zapas
7136       integer i,j,ii,jj,iproc,itask(4),nn
7137 c      write (iout,*) "itask",itask
7138       do i=1,2
7139         iproc=itask(i)
7140         if (iproc.gt.0) then
7141           do j=1,num_cont_hb(ii)
7142             jjc=jcont_hb(j,ii)
7143 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7144             if (jjc.eq.jj) then
7145               ncont_sent(iproc)=ncont_sent(iproc)+1
7146               nn=ncont_sent(iproc)
7147               zapas(1,nn,iproc)=ii
7148               zapas(2,nn,iproc)=jjc
7149               zapas(3,nn,iproc)=d_cont(j,ii)
7150               ind=3
7151               do kk=1,3
7152                 ind=ind+1
7153                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7154               enddo
7155               do kk=1,2
7156                 do ll=1,2
7157                   ind=ind+1
7158                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7159                 enddo
7160               enddo
7161               do jj=1,5
7162                 do kk=1,3
7163                   do ll=1,2
7164                     do mm=1,2
7165                       ind=ind+1
7166                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7167                     enddo
7168                   enddo
7169                 enddo
7170               enddo
7171               exit
7172             endif
7173           enddo
7174         endif
7175       enddo
7176       return
7177       end
7178 c------------------------------------------------------------------------------
7179       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7180       implicit real*8 (a-h,o-z)
7181       include 'DIMENSIONS'
7182       include 'COMMON.IOUNITS'
7183       include 'COMMON.DERIV'
7184       include 'COMMON.INTERACT'
7185       include 'COMMON.CONTACTS'
7186       double precision gx(3),gx1(3)
7187       logical lprn
7188       lprn=.false.
7189       eij=facont_hb(jj,i)
7190       ekl=facont_hb(kk,k)
7191       ees0pij=ees0p(jj,i)
7192       ees0pkl=ees0p(kk,k)
7193       ees0mij=ees0m(jj,i)
7194       ees0mkl=ees0m(kk,k)
7195       ekont=eij*ekl
7196       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7197 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7198 C Following 4 lines for diagnostics.
7199 cd    ees0pkl=0.0D0
7200 cd    ees0pij=1.0D0
7201 cd    ees0mkl=0.0D0
7202 cd    ees0mij=1.0D0
7203 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7204 c     & 'Contacts ',i,j,
7205 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7206 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7207 c     & 'gradcorr_long'
7208 C Calculate the multi-body contribution to energy.
7209 c      ecorr=ecorr+ekont*ees
7210 C Calculate multi-body contributions to the gradient.
7211       coeffpees0pij=coeffp*ees0pij
7212       coeffmees0mij=coeffm*ees0mij
7213       coeffpees0pkl=coeffp*ees0pkl
7214       coeffmees0mkl=coeffm*ees0mkl
7215       do ll=1,3
7216 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7217         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7218      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7219      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7220         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7221      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7222      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7223 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7224         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7225      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7226      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7227         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7228      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7229      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7230         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7231      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7232      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7233         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7234         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7235         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7236      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7237      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7238         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7239         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7240 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7241       enddo
7242 c      write (iout,*)
7243 cgrad      do m=i+1,j-1
7244 cgrad        do ll=1,3
7245 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7246 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7247 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7248 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7249 cgrad        enddo
7250 cgrad      enddo
7251 cgrad      do m=k+1,l-1
7252 cgrad        do ll=1,3
7253 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7254 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7255 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7256 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7257 cgrad        enddo
7258 cgrad      enddo
7259 c      write (iout,*) "ehbcorr",ekont*ees
7260       ehbcorr=ekont*ees
7261       return
7262       end
7263 #ifdef MOMENT
7264 C---------------------------------------------------------------------------
7265       subroutine dipole(i,j,jj)
7266       implicit real*8 (a-h,o-z)
7267       include 'DIMENSIONS'
7268       include 'COMMON.IOUNITS'
7269       include 'COMMON.CHAIN'
7270       include 'COMMON.FFIELD'
7271       include 'COMMON.DERIV'
7272       include 'COMMON.INTERACT'
7273       include 'COMMON.CONTACTS'
7274       include 'COMMON.TORSION'
7275       include 'COMMON.VAR'
7276       include 'COMMON.GEO'
7277       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7278      &  auxmat(2,2)
7279       iti1 = itortyp(itype(i+1))
7280       if (j.lt.nres-1) then
7281         itj1 = itortyp(itype(j+1))
7282       else
7283         itj1=ntortyp+1
7284       endif
7285       do iii=1,2
7286         dipi(iii,1)=Ub2(iii,i)
7287         dipderi(iii)=Ub2der(iii,i)
7288         dipi(iii,2)=b1(iii,iti1)
7289         dipj(iii,1)=Ub2(iii,j)
7290         dipderj(iii)=Ub2der(iii,j)
7291         dipj(iii,2)=b1(iii,itj1)
7292       enddo
7293       kkk=0
7294       do iii=1,2
7295         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7296         do jjj=1,2
7297           kkk=kkk+1
7298           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7299         enddo
7300       enddo
7301       do kkk=1,5
7302         do lll=1,3
7303           mmm=0
7304           do iii=1,2
7305             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7306      &        auxvec(1))
7307             do jjj=1,2
7308               mmm=mmm+1
7309               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7310             enddo
7311           enddo
7312         enddo
7313       enddo
7314       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7315       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7316       do iii=1,2
7317         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7318       enddo
7319       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7320       do iii=1,2
7321         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7322       enddo
7323       return
7324       end
7325 #endif
7326 C---------------------------------------------------------------------------
7327       subroutine calc_eello(i,j,k,l,jj,kk)
7328 C
7329 C This subroutine computes matrices and vectors needed to calculate
7330 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7331 C
7332       implicit real*8 (a-h,o-z)
7333       include 'DIMENSIONS'
7334       include 'COMMON.IOUNITS'
7335       include 'COMMON.CHAIN'
7336       include 'COMMON.DERIV'
7337       include 'COMMON.INTERACT'
7338       include 'COMMON.CONTACTS'
7339       include 'COMMON.TORSION'
7340       include 'COMMON.VAR'
7341       include 'COMMON.GEO'
7342       include 'COMMON.FFIELD'
7343       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7344      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7345       logical lprn
7346       common /kutas/ lprn
7347 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7348 cd     & ' jj=',jj,' kk=',kk
7349 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7350 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7351 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7352       do iii=1,2
7353         do jjj=1,2
7354           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7355           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7356         enddo
7357       enddo
7358       call transpose2(aa1(1,1),aa1t(1,1))
7359       call transpose2(aa2(1,1),aa2t(1,1))
7360       do kkk=1,5
7361         do lll=1,3
7362           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7363      &      aa1tder(1,1,lll,kkk))
7364           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7365      &      aa2tder(1,1,lll,kkk))
7366         enddo
7367       enddo
7368       if (l.eq.j+1) then
7369 C parallel orientation of the two CA-CA-CA frames.
7370         if (i.gt.1) then
7371           iti=itortyp(itype(i))
7372         else
7373           iti=ntortyp+1
7374         endif
7375         itk1=itortyp(itype(k+1))
7376         itj=itortyp(itype(j))
7377         if (l.lt.nres-1) then
7378           itl1=itortyp(itype(l+1))
7379         else
7380           itl1=ntortyp+1
7381         endif
7382 C A1 kernel(j+1) A2T
7383 cd        do iii=1,2
7384 cd          write (iout,'(3f10.5,5x,3f10.5)')
7385 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7386 cd        enddo
7387         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7388      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7389      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7390 C Following matrices are needed only for 6-th order cumulants
7391         IF (wcorr6.gt.0.0d0) THEN
7392         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7393      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7394      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7395         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7396      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7397      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7398      &   ADtEAderx(1,1,1,1,1,1))
7399         lprn=.false.
7400         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7401      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7402      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7403      &   ADtEA1derx(1,1,1,1,1,1))
7404         ENDIF
7405 C End 6-th order cumulants
7406 cd        lprn=.false.
7407 cd        if (lprn) then
7408 cd        write (2,*) 'In calc_eello6'
7409 cd        do iii=1,2
7410 cd          write (2,*) 'iii=',iii
7411 cd          do kkk=1,5
7412 cd            write (2,*) 'kkk=',kkk
7413 cd            do jjj=1,2
7414 cd              write (2,'(3(2f10.5),5x)')
7415 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7416 cd            enddo
7417 cd          enddo
7418 cd        enddo
7419 cd        endif
7420         call transpose2(EUgder(1,1,k),auxmat(1,1))
7421         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7422         call transpose2(EUg(1,1,k),auxmat(1,1))
7423         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7424         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7425         do iii=1,2
7426           do kkk=1,5
7427             do lll=1,3
7428               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7429      &          EAEAderx(1,1,lll,kkk,iii,1))
7430             enddo
7431           enddo
7432         enddo
7433 C A1T kernel(i+1) A2
7434         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7435      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7436      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7437 C Following matrices are needed only for 6-th order cumulants
7438         IF (wcorr6.gt.0.0d0) THEN
7439         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7440      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7441      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7442         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7443      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7444      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7445      &   ADtEAderx(1,1,1,1,1,2))
7446         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7447      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7448      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7449      &   ADtEA1derx(1,1,1,1,1,2))
7450         ENDIF
7451 C End 6-th order cumulants
7452         call transpose2(EUgder(1,1,l),auxmat(1,1))
7453         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7454         call transpose2(EUg(1,1,l),auxmat(1,1))
7455         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7456         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7457         do iii=1,2
7458           do kkk=1,5
7459             do lll=1,3
7460               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7461      &          EAEAderx(1,1,lll,kkk,iii,2))
7462             enddo
7463           enddo
7464         enddo
7465 C AEAb1 and AEAb2
7466 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7467 C They are needed only when the fifth- or the sixth-order cumulants are
7468 C indluded.
7469         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7470         call transpose2(AEA(1,1,1),auxmat(1,1))
7471         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7472         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7473         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7474         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7475         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7476         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7477         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7478         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7479         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7480         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7481         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7482         call transpose2(AEA(1,1,2),auxmat(1,1))
7483         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7484         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7485         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7486         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7487         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7488         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7489         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7490         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7491         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7492         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7493         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7494 C Calculate the Cartesian derivatives of the vectors.
7495         do iii=1,2
7496           do kkk=1,5
7497             do lll=1,3
7498               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7499               call matvec2(auxmat(1,1),b1(1,iti),
7500      &          AEAb1derx(1,lll,kkk,iii,1,1))
7501               call matvec2(auxmat(1,1),Ub2(1,i),
7502      &          AEAb2derx(1,lll,kkk,iii,1,1))
7503               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7504      &          AEAb1derx(1,lll,kkk,iii,2,1))
7505               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7506      &          AEAb2derx(1,lll,kkk,iii,2,1))
7507               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7508               call matvec2(auxmat(1,1),b1(1,itj),
7509      &          AEAb1derx(1,lll,kkk,iii,1,2))
7510               call matvec2(auxmat(1,1),Ub2(1,j),
7511      &          AEAb2derx(1,lll,kkk,iii,1,2))
7512               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7513      &          AEAb1derx(1,lll,kkk,iii,2,2))
7514               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7515      &          AEAb2derx(1,lll,kkk,iii,2,2))
7516             enddo
7517           enddo
7518         enddo
7519         ENDIF
7520 C End vectors
7521       else
7522 C Antiparallel orientation of the two CA-CA-CA frames.
7523         if (i.gt.1) then
7524           iti=itortyp(itype(i))
7525         else
7526           iti=ntortyp+1
7527         endif
7528         itk1=itortyp(itype(k+1))
7529         itl=itortyp(itype(l))
7530         itj=itortyp(itype(j))
7531         if (j.lt.nres-1) then
7532           itj1=itortyp(itype(j+1))
7533         else
7534           itj1=ntortyp+1
7535         endif
7536 C A2 kernel(j-1)T A1T
7537         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7538      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7539      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7540 C Following matrices are needed only for 6-th order cumulants
7541         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7542      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7543         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7544      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7545      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7546         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7547      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7548      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7549      &   ADtEAderx(1,1,1,1,1,1))
7550         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7551      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7552      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7553      &   ADtEA1derx(1,1,1,1,1,1))
7554         ENDIF
7555 C End 6-th order cumulants
7556         call transpose2(EUgder(1,1,k),auxmat(1,1))
7557         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7558         call transpose2(EUg(1,1,k),auxmat(1,1))
7559         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7560         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7561         do iii=1,2
7562           do kkk=1,5
7563             do lll=1,3
7564               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7565      &          EAEAderx(1,1,lll,kkk,iii,1))
7566             enddo
7567           enddo
7568         enddo
7569 C A2T kernel(i+1)T A1
7570         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7571      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7572      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7573 C Following matrices are needed only for 6-th order cumulants
7574         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7575      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7576         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7577      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7578      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7579         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7580      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7581      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7582      &   ADtEAderx(1,1,1,1,1,2))
7583         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7584      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7585      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7586      &   ADtEA1derx(1,1,1,1,1,2))
7587         ENDIF
7588 C End 6-th order cumulants
7589         call transpose2(EUgder(1,1,j),auxmat(1,1))
7590         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7591         call transpose2(EUg(1,1,j),auxmat(1,1))
7592         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7593         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7594         do iii=1,2
7595           do kkk=1,5
7596             do lll=1,3
7597               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7598      &          EAEAderx(1,1,lll,kkk,iii,2))
7599             enddo
7600           enddo
7601         enddo
7602 C AEAb1 and AEAb2
7603 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7604 C They are needed only when the fifth- or the sixth-order cumulants are
7605 C indluded.
7606         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7607      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7608         call transpose2(AEA(1,1,1),auxmat(1,1))
7609         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7610         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7611         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7612         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7613         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7614         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7615         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7616         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7617         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7618         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7619         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7620         call transpose2(AEA(1,1,2),auxmat(1,1))
7621         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7622         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7623         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7624         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7625         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7626         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7627         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7628         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7629         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7630         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7631         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7632 C Calculate the Cartesian derivatives of the vectors.
7633         do iii=1,2
7634           do kkk=1,5
7635             do lll=1,3
7636               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7637               call matvec2(auxmat(1,1),b1(1,iti),
7638      &          AEAb1derx(1,lll,kkk,iii,1,1))
7639               call matvec2(auxmat(1,1),Ub2(1,i),
7640      &          AEAb2derx(1,lll,kkk,iii,1,1))
7641               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7642      &          AEAb1derx(1,lll,kkk,iii,2,1))
7643               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7644      &          AEAb2derx(1,lll,kkk,iii,2,1))
7645               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7646               call matvec2(auxmat(1,1),b1(1,itl),
7647      &          AEAb1derx(1,lll,kkk,iii,1,2))
7648               call matvec2(auxmat(1,1),Ub2(1,l),
7649      &          AEAb2derx(1,lll,kkk,iii,1,2))
7650               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7651      &          AEAb1derx(1,lll,kkk,iii,2,2))
7652               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7653      &          AEAb2derx(1,lll,kkk,iii,2,2))
7654             enddo
7655           enddo
7656         enddo
7657         ENDIF
7658 C End vectors
7659       endif
7660       return
7661       end
7662 C---------------------------------------------------------------------------
7663       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7664      &  KK,KKderg,AKA,AKAderg,AKAderx)
7665       implicit none
7666       integer nderg
7667       logical transp
7668       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7669      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7670      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7671       integer iii,kkk,lll
7672       integer jjj,mmm
7673       logical lprn
7674       common /kutas/ lprn
7675       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7676       do iii=1,nderg
7677         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7678      &    AKAderg(1,1,iii))
7679       enddo
7680 cd      if (lprn) write (2,*) 'In kernel'
7681       do kkk=1,5
7682 cd        if (lprn) write (2,*) 'kkk=',kkk
7683         do lll=1,3
7684           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7685      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7686 cd          if (lprn) then
7687 cd            write (2,*) 'lll=',lll
7688 cd            write (2,*) 'iii=1'
7689 cd            do jjj=1,2
7690 cd              write (2,'(3(2f10.5),5x)')
7691 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7692 cd            enddo
7693 cd          endif
7694           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7695      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7696 cd          if (lprn) then
7697 cd            write (2,*) 'lll=',lll
7698 cd            write (2,*) 'iii=2'
7699 cd            do jjj=1,2
7700 cd              write (2,'(3(2f10.5),5x)')
7701 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7702 cd            enddo
7703 cd          endif
7704         enddo
7705       enddo
7706       return
7707       end
7708 C---------------------------------------------------------------------------
7709       double precision function eello4(i,j,k,l,jj,kk)
7710       implicit real*8 (a-h,o-z)
7711       include 'DIMENSIONS'
7712       include 'COMMON.IOUNITS'
7713       include 'COMMON.CHAIN'
7714       include 'COMMON.DERIV'
7715       include 'COMMON.INTERACT'
7716       include 'COMMON.CONTACTS'
7717       include 'COMMON.TORSION'
7718       include 'COMMON.VAR'
7719       include 'COMMON.GEO'
7720       double precision pizda(2,2),ggg1(3),ggg2(3)
7721 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7722 cd        eello4=0.0d0
7723 cd        return
7724 cd      endif
7725 cd      print *,'eello4:',i,j,k,l,jj,kk
7726 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7727 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7728 cold      eij=facont_hb(jj,i)
7729 cold      ekl=facont_hb(kk,k)
7730 cold      ekont=eij*ekl
7731       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7732 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7733       gcorr_loc(k-1)=gcorr_loc(k-1)
7734      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7735       if (l.eq.j+1) then
7736         gcorr_loc(l-1)=gcorr_loc(l-1)
7737      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7738       else
7739         gcorr_loc(j-1)=gcorr_loc(j-1)
7740      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7741       endif
7742       do iii=1,2
7743         do kkk=1,5
7744           do lll=1,3
7745             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7746      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7747 cd            derx(lll,kkk,iii)=0.0d0
7748           enddo
7749         enddo
7750       enddo
7751 cd      gcorr_loc(l-1)=0.0d0
7752 cd      gcorr_loc(j-1)=0.0d0
7753 cd      gcorr_loc(k-1)=0.0d0
7754 cd      eel4=1.0d0
7755 cd      write (iout,*)'Contacts have occurred for peptide groups',
7756 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7757 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7758       if (j.lt.nres-1) then
7759         j1=j+1
7760         j2=j-1
7761       else
7762         j1=j-1
7763         j2=j-2
7764       endif
7765       if (l.lt.nres-1) then
7766         l1=l+1
7767         l2=l-1
7768       else
7769         l1=l-1
7770         l2=l-2
7771       endif
7772       do ll=1,3
7773 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7774 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7775         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7776         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7777 cgrad        ghalf=0.5d0*ggg1(ll)
7778         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7779         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7780         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7781         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7782         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7783         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7784 cgrad        ghalf=0.5d0*ggg2(ll)
7785         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7786         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7787         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7788         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7789         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7790         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7791       enddo
7792 cgrad      do m=i+1,j-1
7793 cgrad        do ll=1,3
7794 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7795 cgrad        enddo
7796 cgrad      enddo
7797 cgrad      do m=k+1,l-1
7798 cgrad        do ll=1,3
7799 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7800 cgrad        enddo
7801 cgrad      enddo
7802 cgrad      do m=i+2,j2
7803 cgrad        do ll=1,3
7804 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7805 cgrad        enddo
7806 cgrad      enddo
7807 cgrad      do m=k+2,l2
7808 cgrad        do ll=1,3
7809 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7810 cgrad        enddo
7811 cgrad      enddo
7812 cd      do iii=1,nres-3
7813 cd        write (2,*) iii,gcorr_loc(iii)
7814 cd      enddo
7815       eello4=ekont*eel4
7816 cd      write (2,*) 'ekont',ekont
7817 cd      write (iout,*) 'eello4',ekont*eel4
7818       return
7819       end
7820 C---------------------------------------------------------------------------
7821       double precision function eello5(i,j,k,l,jj,kk)
7822       implicit real*8 (a-h,o-z)
7823       include 'DIMENSIONS'
7824       include 'COMMON.IOUNITS'
7825       include 'COMMON.CHAIN'
7826       include 'COMMON.DERIV'
7827       include 'COMMON.INTERACT'
7828       include 'COMMON.CONTACTS'
7829       include 'COMMON.TORSION'
7830       include 'COMMON.VAR'
7831       include 'COMMON.GEO'
7832       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7833       double precision ggg1(3),ggg2(3)
7834 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7835 C                                                                              C
7836 C                            Parallel chains                                   C
7837 C                                                                              C
7838 C          o             o                   o             o                   C
7839 C         /l\           / \             \   / \           / \   /              C
7840 C        /   \         /   \             \ /   \         /   \ /               C
7841 C       j| o |l1       | o |              o| o |         | o |o                C
7842 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7843 C      \i/   \         /   \ /             /   \         /   \                 C
7844 C       o    k1             o                                                  C
7845 C         (I)          (II)                (III)          (IV)                 C
7846 C                                                                              C
7847 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7848 C                                                                              C
7849 C                            Antiparallel chains                               C
7850 C                                                                              C
7851 C          o             o                   o             o                   C
7852 C         /j\           / \             \   / \           / \   /              C
7853 C        /   \         /   \             \ /   \         /   \ /               C
7854 C      j1| o |l        | o |              o| o |         | o |o                C
7855 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7856 C      \i/   \         /   \ /             /   \         /   \                 C
7857 C       o     k1            o                                                  C
7858 C         (I)          (II)                (III)          (IV)                 C
7859 C                                                                              C
7860 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7861 C                                                                              C
7862 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7863 C                                                                              C
7864 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7865 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7866 cd        eello5=0.0d0
7867 cd        return
7868 cd      endif
7869 cd      write (iout,*)
7870 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7871 cd     &   ' and',k,l
7872       itk=itortyp(itype(k))
7873       itl=itortyp(itype(l))
7874       itj=itortyp(itype(j))
7875       eello5_1=0.0d0
7876       eello5_2=0.0d0
7877       eello5_3=0.0d0
7878       eello5_4=0.0d0
7879 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7880 cd     &   eel5_3_num,eel5_4_num)
7881       do iii=1,2
7882         do kkk=1,5
7883           do lll=1,3
7884             derx(lll,kkk,iii)=0.0d0
7885           enddo
7886         enddo
7887       enddo
7888 cd      eij=facont_hb(jj,i)
7889 cd      ekl=facont_hb(kk,k)
7890 cd      ekont=eij*ekl
7891 cd      write (iout,*)'Contacts have occurred for peptide groups',
7892 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7893 cd      goto 1111
7894 C Contribution from the graph I.
7895 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7896 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7897       call transpose2(EUg(1,1,k),auxmat(1,1))
7898       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7899       vv(1)=pizda(1,1)-pizda(2,2)
7900       vv(2)=pizda(1,2)+pizda(2,1)
7901       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7902      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7903 C Explicit gradient in virtual-dihedral angles.
7904       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7905      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7906      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7907       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7908       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7909       vv(1)=pizda(1,1)-pizda(2,2)
7910       vv(2)=pizda(1,2)+pizda(2,1)
7911       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7912      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7913      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7914       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7915       vv(1)=pizda(1,1)-pizda(2,2)
7916       vv(2)=pizda(1,2)+pizda(2,1)
7917       if (l.eq.j+1) then
7918         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7919      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7920      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7921       else
7922         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7923      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7924      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7925       endif
7926 C Cartesian gradient
7927       do iii=1,2
7928         do kkk=1,5
7929           do lll=1,3
7930             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7931      &        pizda(1,1))
7932             vv(1)=pizda(1,1)-pizda(2,2)
7933             vv(2)=pizda(1,2)+pizda(2,1)
7934             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7935      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7936      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7937           enddo
7938         enddo
7939       enddo
7940 c      goto 1112
7941 c1111  continue
7942 C Contribution from graph II
7943       call transpose2(EE(1,1,itk),auxmat(1,1))
7944       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7945       vv(1)=pizda(1,1)+pizda(2,2)
7946       vv(2)=pizda(2,1)-pizda(1,2)
7947       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7948      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7949 C Explicit gradient in virtual-dihedral angles.
7950       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7951      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7952       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7953       vv(1)=pizda(1,1)+pizda(2,2)
7954       vv(2)=pizda(2,1)-pizda(1,2)
7955       if (l.eq.j+1) then
7956         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7957      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7958      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7959       else
7960         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7961      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7962      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7963       endif
7964 C Cartesian gradient
7965       do iii=1,2
7966         do kkk=1,5
7967           do lll=1,3
7968             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7969      &        pizda(1,1))
7970             vv(1)=pizda(1,1)+pizda(2,2)
7971             vv(2)=pizda(2,1)-pizda(1,2)
7972             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7973      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7974      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7975           enddo
7976         enddo
7977       enddo
7978 cd      goto 1112
7979 cd1111  continue
7980       if (l.eq.j+1) then
7981 cd        goto 1110
7982 C Parallel orientation
7983 C Contribution from graph III
7984         call transpose2(EUg(1,1,l),auxmat(1,1))
7985         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7986         vv(1)=pizda(1,1)-pizda(2,2)
7987         vv(2)=pizda(1,2)+pizda(2,1)
7988         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7989      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7990 C Explicit gradient in virtual-dihedral angles.
7991         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7992      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7993      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7994         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7995         vv(1)=pizda(1,1)-pizda(2,2)
7996         vv(2)=pizda(1,2)+pizda(2,1)
7997         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7998      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7999      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8000         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8001         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8002         vv(1)=pizda(1,1)-pizda(2,2)
8003         vv(2)=pizda(1,2)+pizda(2,1)
8004         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8005      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8006      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8007 C Cartesian gradient
8008         do iii=1,2
8009           do kkk=1,5
8010             do lll=1,3
8011               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8012      &          pizda(1,1))
8013               vv(1)=pizda(1,1)-pizda(2,2)
8014               vv(2)=pizda(1,2)+pizda(2,1)
8015               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8016      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8017      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8018             enddo
8019           enddo
8020         enddo
8021 cd        goto 1112
8022 C Contribution from graph IV
8023 cd1110    continue
8024         call transpose2(EE(1,1,itl),auxmat(1,1))
8025         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8026         vv(1)=pizda(1,1)+pizda(2,2)
8027         vv(2)=pizda(2,1)-pizda(1,2)
8028         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8029      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8030 C Explicit gradient in virtual-dihedral angles.
8031         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8032      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8033         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8034         vv(1)=pizda(1,1)+pizda(2,2)
8035         vv(2)=pizda(2,1)-pizda(1,2)
8036         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8037      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8038      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8039 C Cartesian gradient
8040         do iii=1,2
8041           do kkk=1,5
8042             do lll=1,3
8043               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8044      &          pizda(1,1))
8045               vv(1)=pizda(1,1)+pizda(2,2)
8046               vv(2)=pizda(2,1)-pizda(1,2)
8047               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8048      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8049      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8050             enddo
8051           enddo
8052         enddo
8053       else
8054 C Antiparallel orientation
8055 C Contribution from graph III
8056 c        goto 1110
8057         call transpose2(EUg(1,1,j),auxmat(1,1))
8058         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8059         vv(1)=pizda(1,1)-pizda(2,2)
8060         vv(2)=pizda(1,2)+pizda(2,1)
8061         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8062      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8063 C Explicit gradient in virtual-dihedral angles.
8064         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8065      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8066      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8067         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8068         vv(1)=pizda(1,1)-pizda(2,2)
8069         vv(2)=pizda(1,2)+pizda(2,1)
8070         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8071      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8072      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8073         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8074         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8075         vv(1)=pizda(1,1)-pizda(2,2)
8076         vv(2)=pizda(1,2)+pizda(2,1)
8077         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8078      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8079      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8080 C Cartesian gradient
8081         do iii=1,2
8082           do kkk=1,5
8083             do lll=1,3
8084               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8085      &          pizda(1,1))
8086               vv(1)=pizda(1,1)-pizda(2,2)
8087               vv(2)=pizda(1,2)+pizda(2,1)
8088               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8089      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8090      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8091             enddo
8092           enddo
8093         enddo
8094 cd        goto 1112
8095 C Contribution from graph IV
8096 1110    continue
8097         call transpose2(EE(1,1,itj),auxmat(1,1))
8098         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8099         vv(1)=pizda(1,1)+pizda(2,2)
8100         vv(2)=pizda(2,1)-pizda(1,2)
8101         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8102      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8103 C Explicit gradient in virtual-dihedral angles.
8104         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8105      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8106         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8107         vv(1)=pizda(1,1)+pizda(2,2)
8108         vv(2)=pizda(2,1)-pizda(1,2)
8109         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8110      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8111      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8112 C Cartesian gradient
8113         do iii=1,2
8114           do kkk=1,5
8115             do lll=1,3
8116               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8117      &          pizda(1,1))
8118               vv(1)=pizda(1,1)+pizda(2,2)
8119               vv(2)=pizda(2,1)-pizda(1,2)
8120               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8121      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8122      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8123             enddo
8124           enddo
8125         enddo
8126       endif
8127 1112  continue
8128       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8129 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8130 cd        write (2,*) 'ijkl',i,j,k,l
8131 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8132 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8133 cd      endif
8134 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8135 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8136 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8137 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8138       if (j.lt.nres-1) then
8139         j1=j+1
8140         j2=j-1
8141       else
8142         j1=j-1
8143         j2=j-2
8144       endif
8145       if (l.lt.nres-1) then
8146         l1=l+1
8147         l2=l-1
8148       else
8149         l1=l-1
8150         l2=l-2
8151       endif
8152 cd      eij=1.0d0
8153 cd      ekl=1.0d0
8154 cd      ekont=1.0d0
8155 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8156 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8157 C        summed up outside the subrouine as for the other subroutines
8158 C        handling long-range interactions. The old code is commented out
8159 C        with "cgrad" to keep track of changes.
8160       do ll=1,3
8161 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8162 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8163         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8164         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8165 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8166 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8167 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8168 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8169 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8170 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8171 c     &   gradcorr5ij,
8172 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8173 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8174 cgrad        ghalf=0.5d0*ggg1(ll)
8175 cd        ghalf=0.0d0
8176         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8177         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8178         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8179         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8180         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8181         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8182 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8183 cgrad        ghalf=0.5d0*ggg2(ll)
8184 cd        ghalf=0.0d0
8185         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8186         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8187         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8188         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8189         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8190         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8191       enddo
8192 cd      goto 1112
8193 cgrad      do m=i+1,j-1
8194 cgrad        do ll=1,3
8195 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8196 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8197 cgrad        enddo
8198 cgrad      enddo
8199 cgrad      do m=k+1,l-1
8200 cgrad        do ll=1,3
8201 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8202 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8203 cgrad        enddo
8204 cgrad      enddo
8205 c1112  continue
8206 cgrad      do m=i+2,j2
8207 cgrad        do ll=1,3
8208 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8209 cgrad        enddo
8210 cgrad      enddo
8211 cgrad      do m=k+2,l2
8212 cgrad        do ll=1,3
8213 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8214 cgrad        enddo
8215 cgrad      enddo
8216 cd      do iii=1,nres-3
8217 cd        write (2,*) iii,g_corr5_loc(iii)
8218 cd      enddo
8219       eello5=ekont*eel5
8220 cd      write (2,*) 'ekont',ekont
8221 cd      write (iout,*) 'eello5',ekont*eel5
8222       return
8223       end
8224 c--------------------------------------------------------------------------
8225       double precision function eello6(i,j,k,l,jj,kk)
8226       implicit real*8 (a-h,o-z)
8227       include 'DIMENSIONS'
8228       include 'COMMON.IOUNITS'
8229       include 'COMMON.CHAIN'
8230       include 'COMMON.DERIV'
8231       include 'COMMON.INTERACT'
8232       include 'COMMON.CONTACTS'
8233       include 'COMMON.TORSION'
8234       include 'COMMON.VAR'
8235       include 'COMMON.GEO'
8236       include 'COMMON.FFIELD'
8237       double precision ggg1(3),ggg2(3)
8238 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8239 cd        eello6=0.0d0
8240 cd        return
8241 cd      endif
8242 cd      write (iout,*)
8243 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8244 cd     &   ' and',k,l
8245       eello6_1=0.0d0
8246       eello6_2=0.0d0
8247       eello6_3=0.0d0
8248       eello6_4=0.0d0
8249       eello6_5=0.0d0
8250       eello6_6=0.0d0
8251 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8252 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8253       do iii=1,2
8254         do kkk=1,5
8255           do lll=1,3
8256             derx(lll,kkk,iii)=0.0d0
8257           enddo
8258         enddo
8259       enddo
8260 cd      eij=facont_hb(jj,i)
8261 cd      ekl=facont_hb(kk,k)
8262 cd      ekont=eij*ekl
8263 cd      eij=1.0d0
8264 cd      ekl=1.0d0
8265 cd      ekont=1.0d0
8266       if (l.eq.j+1) then
8267         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8268         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8269         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8270         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8271         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8272         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8273       else
8274         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8275         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8276         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8277         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8278         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8279           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8280         else
8281           eello6_5=0.0d0
8282         endif
8283         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8284       endif
8285 C If turn contributions are considered, they will be handled separately.
8286       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8287 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8288 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8289 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8290 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8291 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8292 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8293 cd      goto 1112
8294       if (j.lt.nres-1) then
8295         j1=j+1
8296         j2=j-1
8297       else
8298         j1=j-1
8299         j2=j-2
8300       endif
8301       if (l.lt.nres-1) then
8302         l1=l+1
8303         l2=l-1
8304       else
8305         l1=l-1
8306         l2=l-2
8307       endif
8308       do ll=1,3
8309 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8310 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8311 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8312 cgrad        ghalf=0.5d0*ggg1(ll)
8313 cd        ghalf=0.0d0
8314         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8315         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8316         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8317         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8318         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8319         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8320         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8321         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8322 cgrad        ghalf=0.5d0*ggg2(ll)
8323 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8324 cd        ghalf=0.0d0
8325         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8326         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8327         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8328         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8329         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8330         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8331       enddo
8332 cd      goto 1112
8333 cgrad      do m=i+1,j-1
8334 cgrad        do ll=1,3
8335 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8336 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8337 cgrad        enddo
8338 cgrad      enddo
8339 cgrad      do m=k+1,l-1
8340 cgrad        do ll=1,3
8341 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8342 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8343 cgrad        enddo
8344 cgrad      enddo
8345 cgrad1112  continue
8346 cgrad      do m=i+2,j2
8347 cgrad        do ll=1,3
8348 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8349 cgrad        enddo
8350 cgrad      enddo
8351 cgrad      do m=k+2,l2
8352 cgrad        do ll=1,3
8353 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8354 cgrad        enddo
8355 cgrad      enddo
8356 cd      do iii=1,nres-3
8357 cd        write (2,*) iii,g_corr6_loc(iii)
8358 cd      enddo
8359       eello6=ekont*eel6
8360 cd      write (2,*) 'ekont',ekont
8361 cd      write (iout,*) 'eello6',ekont*eel6
8362       return
8363       end
8364 c--------------------------------------------------------------------------
8365       double precision function eello6_graph1(i,j,k,l,imat,swap)
8366       implicit real*8 (a-h,o-z)
8367       include 'DIMENSIONS'
8368       include 'COMMON.IOUNITS'
8369       include 'COMMON.CHAIN'
8370       include 'COMMON.DERIV'
8371       include 'COMMON.INTERACT'
8372       include 'COMMON.CONTACTS'
8373       include 'COMMON.TORSION'
8374       include 'COMMON.VAR'
8375       include 'COMMON.GEO'
8376       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8377       logical swap
8378       logical lprn
8379       common /kutas/ lprn
8380 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8381 C
8382 C      Parallel       Antiparallel
8383 C
8384 C          o             o
8385 C         /l\           /j\
8386 C        /   \         /   \
8387 C       /| o |         | o |\
8388 C     \ j|/k\|  /   \  |/k\|l /
8389 C      \ /   \ /     \ /   \ /
8390 C       o     o       o     o
8391 C       i             i
8392 C
8393 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8394       itk=itortyp(itype(k))
8395       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8396       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8397       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8398       call transpose2(EUgC(1,1,k),auxmat(1,1))
8399       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8400       vv1(1)=pizda1(1,1)-pizda1(2,2)
8401       vv1(2)=pizda1(1,2)+pizda1(2,1)
8402       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8403       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8404       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8405       s5=scalar2(vv(1),Dtobr2(1,i))
8406 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8407       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8408       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8409      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8410      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8411      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8412      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8413      & +scalar2(vv(1),Dtobr2der(1,i)))
8414       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8415       vv1(1)=pizda1(1,1)-pizda1(2,2)
8416       vv1(2)=pizda1(1,2)+pizda1(2,1)
8417       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8418       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8419       if (l.eq.j+1) then
8420         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8421      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8422      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8423      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8424      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8425       else
8426         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8427      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8428      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8429      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8430      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8431       endif
8432       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8433       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8434       vv1(1)=pizda1(1,1)-pizda1(2,2)
8435       vv1(2)=pizda1(1,2)+pizda1(2,1)
8436       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8437      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8438      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8439      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8440       do iii=1,2
8441         if (swap) then
8442           ind=3-iii
8443         else
8444           ind=iii
8445         endif
8446         do kkk=1,5
8447           do lll=1,3
8448             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8449             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8450             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8451             call transpose2(EUgC(1,1,k),auxmat(1,1))
8452             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8453      &        pizda1(1,1))
8454             vv1(1)=pizda1(1,1)-pizda1(2,2)
8455             vv1(2)=pizda1(1,2)+pizda1(2,1)
8456             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8457             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8458      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8459             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8460      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8461             s5=scalar2(vv(1),Dtobr2(1,i))
8462             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8463           enddo
8464         enddo
8465       enddo
8466       return
8467       end
8468 c----------------------------------------------------------------------------
8469       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8470       implicit real*8 (a-h,o-z)
8471       include 'DIMENSIONS'
8472       include 'COMMON.IOUNITS'
8473       include 'COMMON.CHAIN'
8474       include 'COMMON.DERIV'
8475       include 'COMMON.INTERACT'
8476       include 'COMMON.CONTACTS'
8477       include 'COMMON.TORSION'
8478       include 'COMMON.VAR'
8479       include 'COMMON.GEO'
8480       logical swap
8481       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8482      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8483       logical lprn
8484       common /kutas/ lprn
8485 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8486 C                                                                              C
8487 C      Parallel       Antiparallel                                             C
8488 C                                                                              C
8489 C          o             o                                                     C
8490 C     \   /l\           /j\   /                                                C
8491 C      \ /   \         /   \ /                                                 C
8492 C       o| o |         | o |o                                                  C
8493 C     \ j|/k\|      \  |/k\|l                                                  C
8494 C      \ /   \       \ /   \                                                   C
8495 C       o             o                                                        C
8496 C       i             i                                                        C
8497 C                                                                              C
8498 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8499 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8500 C AL 7/4/01 s1 would occur in the sixth-order moment,
8501 C           but not in a cluster cumulant
8502 #ifdef MOMENT
8503       s1=dip(1,jj,i)*dip(1,kk,k)
8504 #endif
8505       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8506       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8507       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8508       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8509       call transpose2(EUg(1,1,k),auxmat(1,1))
8510       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8511       vv(1)=pizda(1,1)-pizda(2,2)
8512       vv(2)=pizda(1,2)+pizda(2,1)
8513       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8514 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8515 #ifdef MOMENT
8516       eello6_graph2=-(s1+s2+s3+s4)
8517 #else
8518       eello6_graph2=-(s2+s3+s4)
8519 #endif
8520 c      eello6_graph2=-s3
8521 C Derivatives in gamma(i-1)
8522       if (i.gt.1) then
8523 #ifdef MOMENT
8524         s1=dipderg(1,jj,i)*dip(1,kk,k)
8525 #endif
8526         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8527         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8528         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8529         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8530 #ifdef MOMENT
8531         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8532 #else
8533         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8534 #endif
8535 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8536       endif
8537 C Derivatives in gamma(k-1)
8538 #ifdef MOMENT
8539       s1=dip(1,jj,i)*dipderg(1,kk,k)
8540 #endif
8541       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8542       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8543       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8544       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8545       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8546       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8547       vv(1)=pizda(1,1)-pizda(2,2)
8548       vv(2)=pizda(1,2)+pizda(2,1)
8549       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8550 #ifdef MOMENT
8551       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8552 #else
8553       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8554 #endif
8555 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8556 C Derivatives in gamma(j-1) or gamma(l-1)
8557       if (j.gt.1) then
8558 #ifdef MOMENT
8559         s1=dipderg(3,jj,i)*dip(1,kk,k)
8560 #endif
8561         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8562         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8563         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8564         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8565         vv(1)=pizda(1,1)-pizda(2,2)
8566         vv(2)=pizda(1,2)+pizda(2,1)
8567         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8568 #ifdef MOMENT
8569         if (swap) then
8570           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8571         else
8572           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8573         endif
8574 #endif
8575         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8576 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8577       endif
8578 C Derivatives in gamma(l-1) or gamma(j-1)
8579       if (l.gt.1) then
8580 #ifdef MOMENT
8581         s1=dip(1,jj,i)*dipderg(3,kk,k)
8582 #endif
8583         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8584         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8585         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8586         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8587         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8588         vv(1)=pizda(1,1)-pizda(2,2)
8589         vv(2)=pizda(1,2)+pizda(2,1)
8590         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8591 #ifdef MOMENT
8592         if (swap) then
8593           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8594         else
8595           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8596         endif
8597 #endif
8598         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8599 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8600       endif
8601 C Cartesian derivatives.
8602       if (lprn) then
8603         write (2,*) 'In eello6_graph2'
8604         do iii=1,2
8605           write (2,*) 'iii=',iii
8606           do kkk=1,5
8607             write (2,*) 'kkk=',kkk
8608             do jjj=1,2
8609               write (2,'(3(2f10.5),5x)')
8610      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8611             enddo
8612           enddo
8613         enddo
8614       endif
8615       do iii=1,2
8616         do kkk=1,5
8617           do lll=1,3
8618 #ifdef MOMENT
8619             if (iii.eq.1) then
8620               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8621             else
8622               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8623             endif
8624 #endif
8625             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8626      &        auxvec(1))
8627             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8628             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8629      &        auxvec(1))
8630             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8631             call transpose2(EUg(1,1,k),auxmat(1,1))
8632             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8633      &        pizda(1,1))
8634             vv(1)=pizda(1,1)-pizda(2,2)
8635             vv(2)=pizda(1,2)+pizda(2,1)
8636             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8637 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8638 #ifdef MOMENT
8639             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8640 #else
8641             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8642 #endif
8643             if (swap) then
8644               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8645             else
8646               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8647             endif
8648           enddo
8649         enddo
8650       enddo
8651       return
8652       end
8653 c----------------------------------------------------------------------------
8654       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8655       implicit real*8 (a-h,o-z)
8656       include 'DIMENSIONS'
8657       include 'COMMON.IOUNITS'
8658       include 'COMMON.CHAIN'
8659       include 'COMMON.DERIV'
8660       include 'COMMON.INTERACT'
8661       include 'COMMON.CONTACTS'
8662       include 'COMMON.TORSION'
8663       include 'COMMON.VAR'
8664       include 'COMMON.GEO'
8665       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8666       logical swap
8667 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8668 C                                                                              C
8669 C      Parallel       Antiparallel                                             C
8670 C                                                                              C
8671 C          o             o                                                     C
8672 C         /l\   /   \   /j\                                                    C
8673 C        /   \ /     \ /   \                                                   C
8674 C       /| o |o       o| o |\                                                  C
8675 C       j|/k\|  /      |/k\|l /                                                C
8676 C        /   \ /       /   \ /                                                 C
8677 C       /     o       /     o                                                  C
8678 C       i             i                                                        C
8679 C                                                                              C
8680 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8681 C
8682 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8683 C           energy moment and not to the cluster cumulant.
8684       iti=itortyp(itype(i))
8685       if (j.lt.nres-1) then
8686         itj1=itortyp(itype(j+1))
8687       else
8688         itj1=ntortyp+1
8689       endif
8690       itk=itortyp(itype(k))
8691       itk1=itortyp(itype(k+1))
8692       if (l.lt.nres-1) then
8693         itl1=itortyp(itype(l+1))
8694       else
8695         itl1=ntortyp+1
8696       endif
8697 #ifdef MOMENT
8698       s1=dip(4,jj,i)*dip(4,kk,k)
8699 #endif
8700       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8701       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8702       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8703       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8704       call transpose2(EE(1,1,itk),auxmat(1,1))
8705       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8706       vv(1)=pizda(1,1)+pizda(2,2)
8707       vv(2)=pizda(2,1)-pizda(1,2)
8708       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8709 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8710 cd     & "sum",-(s2+s3+s4)
8711 #ifdef MOMENT
8712       eello6_graph3=-(s1+s2+s3+s4)
8713 #else
8714       eello6_graph3=-(s2+s3+s4)
8715 #endif
8716 c      eello6_graph3=-s4
8717 C Derivatives in gamma(k-1)
8718       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8719       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8720       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8721       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8722 C Derivatives in gamma(l-1)
8723       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8724       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8725       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8726       vv(1)=pizda(1,1)+pizda(2,2)
8727       vv(2)=pizda(2,1)-pizda(1,2)
8728       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8729       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8730 C Cartesian derivatives.
8731       do iii=1,2
8732         do kkk=1,5
8733           do lll=1,3
8734 #ifdef MOMENT
8735             if (iii.eq.1) then
8736               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8737             else
8738               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8739             endif
8740 #endif
8741             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8742      &        auxvec(1))
8743             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8744             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8745      &        auxvec(1))
8746             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8747             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8748      &        pizda(1,1))
8749             vv(1)=pizda(1,1)+pizda(2,2)
8750             vv(2)=pizda(2,1)-pizda(1,2)
8751             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8752 #ifdef MOMENT
8753             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8754 #else
8755             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8756 #endif
8757             if (swap) then
8758               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8759             else
8760               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8761             endif
8762 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8763           enddo
8764         enddo
8765       enddo
8766       return
8767       end
8768 c----------------------------------------------------------------------------
8769       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8770       implicit real*8 (a-h,o-z)
8771       include 'DIMENSIONS'
8772       include 'COMMON.IOUNITS'
8773       include 'COMMON.CHAIN'
8774       include 'COMMON.DERIV'
8775       include 'COMMON.INTERACT'
8776       include 'COMMON.CONTACTS'
8777       include 'COMMON.TORSION'
8778       include 'COMMON.VAR'
8779       include 'COMMON.GEO'
8780       include 'COMMON.FFIELD'
8781       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8782      & auxvec1(2),auxmat1(2,2)
8783       logical swap
8784 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8785 C                                                                              C
8786 C      Parallel       Antiparallel                                             C
8787 C                                                                              C
8788 C          o             o                                                     C
8789 C         /l\   /   \   /j\                                                    C
8790 C        /   \ /     \ /   \                                                   C
8791 C       /| o |o       o| o |\                                                  C
8792 C     \ j|/k\|      \  |/k\|l                                                  C
8793 C      \ /   \       \ /   \                                                   C
8794 C       o     \       o     \                                                  C
8795 C       i             i                                                        C
8796 C                                                                              C
8797 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8798 C
8799 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8800 C           energy moment and not to the cluster cumulant.
8801 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8802       iti=itortyp(itype(i))
8803       itj=itortyp(itype(j))
8804       if (j.lt.nres-1) then
8805         itj1=itortyp(itype(j+1))
8806       else
8807         itj1=ntortyp+1
8808       endif
8809       itk=itortyp(itype(k))
8810       if (k.lt.nres-1) then
8811         itk1=itortyp(itype(k+1))
8812       else
8813         itk1=ntortyp+1
8814       endif
8815       itl=itortyp(itype(l))
8816       if (l.lt.nres-1) then
8817         itl1=itortyp(itype(l+1))
8818       else
8819         itl1=ntortyp+1
8820       endif
8821 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8822 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8823 cd     & ' itl',itl,' itl1',itl1
8824 #ifdef MOMENT
8825       if (imat.eq.1) then
8826         s1=dip(3,jj,i)*dip(3,kk,k)
8827       else
8828         s1=dip(2,jj,j)*dip(2,kk,l)
8829       endif
8830 #endif
8831       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8832       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8833       if (j.eq.l+1) then
8834         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8835         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8836       else
8837         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8838         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8839       endif
8840       call transpose2(EUg(1,1,k),auxmat(1,1))
8841       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8842       vv(1)=pizda(1,1)-pizda(2,2)
8843       vv(2)=pizda(2,1)+pizda(1,2)
8844       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8845 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8846 #ifdef MOMENT
8847       eello6_graph4=-(s1+s2+s3+s4)
8848 #else
8849       eello6_graph4=-(s2+s3+s4)
8850 #endif
8851 C Derivatives in gamma(i-1)
8852       if (i.gt.1) then
8853 #ifdef MOMENT
8854         if (imat.eq.1) then
8855           s1=dipderg(2,jj,i)*dip(3,kk,k)
8856         else
8857           s1=dipderg(4,jj,j)*dip(2,kk,l)
8858         endif
8859 #endif
8860         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8861         if (j.eq.l+1) then
8862           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8863           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8864         else
8865           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8866           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8867         endif
8868         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8869         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8870 cd          write (2,*) 'turn6 derivatives'
8871 #ifdef MOMENT
8872           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8873 #else
8874           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8875 #endif
8876         else
8877 #ifdef MOMENT
8878           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8879 #else
8880           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8881 #endif
8882         endif
8883       endif
8884 C Derivatives in gamma(k-1)
8885 #ifdef MOMENT
8886       if (imat.eq.1) then
8887         s1=dip(3,jj,i)*dipderg(2,kk,k)
8888       else
8889         s1=dip(2,jj,j)*dipderg(4,kk,l)
8890       endif
8891 #endif
8892       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8893       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8894       if (j.eq.l+1) then
8895         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8896         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8897       else
8898         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8899         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8900       endif
8901       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8902       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8903       vv(1)=pizda(1,1)-pizda(2,2)
8904       vv(2)=pizda(2,1)+pizda(1,2)
8905       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8906       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8907 #ifdef MOMENT
8908         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8909 #else
8910         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8911 #endif
8912       else
8913 #ifdef MOMENT
8914         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8915 #else
8916         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8917 #endif
8918       endif
8919 C Derivatives in gamma(j-1) or gamma(l-1)
8920       if (l.eq.j+1 .and. l.gt.1) then
8921         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8922         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8923         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8924         vv(1)=pizda(1,1)-pizda(2,2)
8925         vv(2)=pizda(2,1)+pizda(1,2)
8926         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8927         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8928       else if (j.gt.1) then
8929         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8930         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8931         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8932         vv(1)=pizda(1,1)-pizda(2,2)
8933         vv(2)=pizda(2,1)+pizda(1,2)
8934         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8935         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8936           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8937         else
8938           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8939         endif
8940       endif
8941 C Cartesian derivatives.
8942       do iii=1,2
8943         do kkk=1,5
8944           do lll=1,3
8945 #ifdef MOMENT
8946             if (iii.eq.1) then
8947               if (imat.eq.1) then
8948                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8949               else
8950                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8951               endif
8952             else
8953               if (imat.eq.1) then
8954                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8955               else
8956                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8957               endif
8958             endif
8959 #endif
8960             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8961      &        auxvec(1))
8962             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8963             if (j.eq.l+1) then
8964               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8965      &          b1(1,itj1),auxvec(1))
8966               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8967             else
8968               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8969      &          b1(1,itl1),auxvec(1))
8970               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8971             endif
8972             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8973      &        pizda(1,1))
8974             vv(1)=pizda(1,1)-pizda(2,2)
8975             vv(2)=pizda(2,1)+pizda(1,2)
8976             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8977             if (swap) then
8978               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8979 #ifdef MOMENT
8980                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8981      &             -(s1+s2+s4)
8982 #else
8983                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8984      &             -(s2+s4)
8985 #endif
8986                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8987               else
8988 #ifdef MOMENT
8989                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8990 #else
8991                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8992 #endif
8993                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8994               endif
8995             else
8996 #ifdef MOMENT
8997               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8998 #else
8999               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9000 #endif
9001               if (l.eq.j+1) then
9002                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9003               else
9004                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9005               endif
9006             endif
9007           enddo
9008         enddo
9009       enddo
9010       return
9011       end
9012 c----------------------------------------------------------------------------
9013       double precision function eello_turn6(i,jj,kk)
9014       implicit real*8 (a-h,o-z)
9015       include 'DIMENSIONS'
9016       include 'COMMON.IOUNITS'
9017       include 'COMMON.CHAIN'
9018       include 'COMMON.DERIV'
9019       include 'COMMON.INTERACT'
9020       include 'COMMON.CONTACTS'
9021       include 'COMMON.TORSION'
9022       include 'COMMON.VAR'
9023       include 'COMMON.GEO'
9024       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9025      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9026      &  ggg1(3),ggg2(3)
9027       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9028      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9029 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9030 C           the respective energy moment and not to the cluster cumulant.
9031       s1=0.0d0
9032       s8=0.0d0
9033       s13=0.0d0
9034 c
9035       eello_turn6=0.0d0
9036       j=i+4
9037       k=i+1
9038       l=i+3
9039       iti=itortyp(itype(i))
9040       itk=itortyp(itype(k))
9041       itk1=itortyp(itype(k+1))
9042       itl=itortyp(itype(l))
9043       itj=itortyp(itype(j))
9044 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9045 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9046 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9047 cd        eello6=0.0d0
9048 cd        return
9049 cd      endif
9050 cd      write (iout,*)
9051 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9052 cd     &   ' and',k,l
9053 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9054       do iii=1,2
9055         do kkk=1,5
9056           do lll=1,3
9057             derx_turn(lll,kkk,iii)=0.0d0
9058           enddo
9059         enddo
9060       enddo
9061 cd      eij=1.0d0
9062 cd      ekl=1.0d0
9063 cd      ekont=1.0d0
9064       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9065 cd      eello6_5=0.0d0
9066 cd      write (2,*) 'eello6_5',eello6_5
9067 #ifdef MOMENT
9068       call transpose2(AEA(1,1,1),auxmat(1,1))
9069       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9070       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9071       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9072 #endif
9073       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9074       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9075       s2 = scalar2(b1(1,itk),vtemp1(1))
9076 #ifdef MOMENT
9077       call transpose2(AEA(1,1,2),atemp(1,1))
9078       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9079       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9080       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9081 #endif
9082       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9083       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9084       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9085 #ifdef MOMENT
9086       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9087       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9088       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9089       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9090       ss13 = scalar2(b1(1,itk),vtemp4(1))
9091       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9092 #endif
9093 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9094 c      s1=0.0d0
9095 c      s2=0.0d0
9096 c      s8=0.0d0
9097 c      s12=0.0d0
9098 c      s13=0.0d0
9099       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9100 C Derivatives in gamma(i+2)
9101       s1d =0.0d0
9102       s8d =0.0d0
9103 #ifdef MOMENT
9104       call transpose2(AEA(1,1,1),auxmatd(1,1))
9105       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9106       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9107       call transpose2(AEAderg(1,1,2),atempd(1,1))
9108       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9109       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9110 #endif
9111       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9112       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9113       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9114 c      s1d=0.0d0
9115 c      s2d=0.0d0
9116 c      s8d=0.0d0
9117 c      s12d=0.0d0
9118 c      s13d=0.0d0
9119       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9120 C Derivatives in gamma(i+3)
9121 #ifdef MOMENT
9122       call transpose2(AEA(1,1,1),auxmatd(1,1))
9123       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9124       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9125       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9126 #endif
9127       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9128       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9129       s2d = scalar2(b1(1,itk),vtemp1d(1))
9130 #ifdef MOMENT
9131       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9132       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9133 #endif
9134       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9135 #ifdef MOMENT
9136       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9137       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9138       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9139 #endif
9140 c      s1d=0.0d0
9141 c      s2d=0.0d0
9142 c      s8d=0.0d0
9143 c      s12d=0.0d0
9144 c      s13d=0.0d0
9145 #ifdef MOMENT
9146       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9147      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9148 #else
9149       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9150      &               -0.5d0*ekont*(s2d+s12d)
9151 #endif
9152 C Derivatives in gamma(i+4)
9153       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9154       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9155       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9156 #ifdef MOMENT
9157       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9158       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9159       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9160 #endif
9161 c      s1d=0.0d0
9162 c      s2d=0.0d0
9163 c      s8d=0.0d0
9164 C      s12d=0.0d0
9165 c      s13d=0.0d0
9166 #ifdef MOMENT
9167       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9168 #else
9169       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9170 #endif
9171 C Derivatives in gamma(i+5)
9172 #ifdef MOMENT
9173       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9174       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9175       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9176 #endif
9177       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9178       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9179       s2d = scalar2(b1(1,itk),vtemp1d(1))
9180 #ifdef MOMENT
9181       call transpose2(AEA(1,1,2),atempd(1,1))
9182       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9183       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9184 #endif
9185       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9186       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9187 #ifdef MOMENT
9188       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9189       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9190       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9191 #endif
9192 c      s1d=0.0d0
9193 c      s2d=0.0d0
9194 c      s8d=0.0d0
9195 c      s12d=0.0d0
9196 c      s13d=0.0d0
9197 #ifdef MOMENT
9198       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9199      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9200 #else
9201       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9202      &               -0.5d0*ekont*(s2d+s12d)
9203 #endif
9204 C Cartesian derivatives
9205       do iii=1,2
9206         do kkk=1,5
9207           do lll=1,3
9208 #ifdef MOMENT
9209             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9210             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9211             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9212 #endif
9213             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9214             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9215      &          vtemp1d(1))
9216             s2d = scalar2(b1(1,itk),vtemp1d(1))
9217 #ifdef MOMENT
9218             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9219             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9220             s8d = -(atempd(1,1)+atempd(2,2))*
9221      &           scalar2(cc(1,1,itl),vtemp2(1))
9222 #endif
9223             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9224      &           auxmatd(1,1))
9225             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9226             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9227 c      s1d=0.0d0
9228 c      s2d=0.0d0
9229 c      s8d=0.0d0
9230 c      s12d=0.0d0
9231 c      s13d=0.0d0
9232 #ifdef MOMENT
9233             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9234      &        - 0.5d0*(s1d+s2d)
9235 #else
9236             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9237      &        - 0.5d0*s2d
9238 #endif
9239 #ifdef MOMENT
9240             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9241      &        - 0.5d0*(s8d+s12d)
9242 #else
9243             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9244      &        - 0.5d0*s12d
9245 #endif
9246           enddo
9247         enddo
9248       enddo
9249 #ifdef MOMENT
9250       do kkk=1,5
9251         do lll=1,3
9252           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9253      &      achuj_tempd(1,1))
9254           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9255           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9256           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9257           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9258           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9259      &      vtemp4d(1))
9260           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9261           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9262           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9263         enddo
9264       enddo
9265 #endif
9266 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9267 cd     &  16*eel_turn6_num
9268 cd      goto 1112
9269       if (j.lt.nres-1) then
9270         j1=j+1
9271         j2=j-1
9272       else
9273         j1=j-1
9274         j2=j-2
9275       endif
9276       if (l.lt.nres-1) then
9277         l1=l+1
9278         l2=l-1
9279       else
9280         l1=l-1
9281         l2=l-2
9282       endif
9283       do ll=1,3
9284 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9285 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9286 cgrad        ghalf=0.5d0*ggg1(ll)
9287 cd        ghalf=0.0d0
9288         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9289         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9290         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9291      &    +ekont*derx_turn(ll,2,1)
9292         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9293         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9294      &    +ekont*derx_turn(ll,4,1)
9295         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9296         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9297         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9298 cgrad        ghalf=0.5d0*ggg2(ll)
9299 cd        ghalf=0.0d0
9300         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9301      &    +ekont*derx_turn(ll,2,2)
9302         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9303         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9304      &    +ekont*derx_turn(ll,4,2)
9305         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9306         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9307         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9308       enddo
9309 cd      goto 1112
9310 cgrad      do m=i+1,j-1
9311 cgrad        do ll=1,3
9312 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9313 cgrad        enddo
9314 cgrad      enddo
9315 cgrad      do m=k+1,l-1
9316 cgrad        do ll=1,3
9317 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9318 cgrad        enddo
9319 cgrad      enddo
9320 cgrad1112  continue
9321 cgrad      do m=i+2,j2
9322 cgrad        do ll=1,3
9323 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9324 cgrad        enddo
9325 cgrad      enddo
9326 cgrad      do m=k+2,l2
9327 cgrad        do ll=1,3
9328 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9329 cgrad        enddo
9330 cgrad      enddo
9331 cd      do iii=1,nres-3
9332 cd        write (2,*) iii,g_corr6_loc(iii)
9333 cd      enddo
9334       eello_turn6=ekont*eel_turn6
9335 cd      write (2,*) 'ekont',ekont
9336 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9337       return
9338       end
9339
9340 C-----------------------------------------------------------------------------
9341       double precision function scalar(u,v)
9342 !DIR$ INLINEALWAYS scalar
9343 #ifndef OSF
9344 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9345 #endif
9346       implicit none
9347       double precision u(3),v(3)
9348 cd      double precision sc
9349 cd      integer i
9350 cd      sc=0.0d0
9351 cd      do i=1,3
9352 cd        sc=sc+u(i)*v(i)
9353 cd      enddo
9354 cd      scalar=sc
9355
9356       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9357       return
9358       end
9359 crc-------------------------------------------------
9360       SUBROUTINE MATVEC2(A1,V1,V2)
9361 !DIR$ INLINEALWAYS MATVEC2
9362 #ifndef OSF
9363 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9364 #endif
9365       implicit real*8 (a-h,o-z)
9366       include 'DIMENSIONS'
9367       DIMENSION A1(2,2),V1(2),V2(2)
9368 c      DO 1 I=1,2
9369 c        VI=0.0
9370 c        DO 3 K=1,2
9371 c    3     VI=VI+A1(I,K)*V1(K)
9372 c        Vaux(I)=VI
9373 c    1 CONTINUE
9374
9375       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9376       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9377
9378       v2(1)=vaux1
9379       v2(2)=vaux2
9380       END
9381 C---------------------------------------
9382       SUBROUTINE MATMAT2(A1,A2,A3)
9383 #ifndef OSF
9384 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9385 #endif
9386       implicit real*8 (a-h,o-z)
9387       include 'DIMENSIONS'
9388       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9389 c      DIMENSION AI3(2,2)
9390 c        DO  J=1,2
9391 c          A3IJ=0.0
9392 c          DO K=1,2
9393 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9394 c          enddo
9395 c          A3(I,J)=A3IJ
9396 c       enddo
9397 c      enddo
9398
9399       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9400       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9401       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9402       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9403
9404       A3(1,1)=AI3_11
9405       A3(2,1)=AI3_21
9406       A3(1,2)=AI3_12
9407       A3(2,2)=AI3_22
9408       END
9409
9410 c-------------------------------------------------------------------------
9411       double precision function scalar2(u,v)
9412 !DIR$ INLINEALWAYS scalar2
9413       implicit none
9414       double precision u(2),v(2)
9415       double precision sc
9416       integer i
9417       scalar2=u(1)*v(1)+u(2)*v(2)
9418       return
9419       end
9420
9421 C-----------------------------------------------------------------------------
9422
9423       subroutine transpose2(a,at)
9424 !DIR$ INLINEALWAYS transpose2
9425 #ifndef OSF
9426 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9427 #endif
9428       implicit none
9429       double precision a(2,2),at(2,2)
9430       at(1,1)=a(1,1)
9431       at(1,2)=a(2,1)
9432       at(2,1)=a(1,2)
9433       at(2,2)=a(2,2)
9434       return
9435       end
9436 c--------------------------------------------------------------------------
9437       subroutine transpose(n,a,at)
9438       implicit none
9439       integer n,i,j
9440       double precision a(n,n),at(n,n)
9441       do i=1,n
9442         do j=1,n
9443           at(j,i)=a(i,j)
9444         enddo
9445       enddo
9446       return
9447       end
9448 C---------------------------------------------------------------------------
9449       subroutine prodmat3(a1,a2,kk,transp,prod)
9450 !DIR$ INLINEALWAYS prodmat3
9451 #ifndef OSF
9452 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9453 #endif
9454       implicit none
9455       integer i,j
9456       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9457       logical transp
9458 crc      double precision auxmat(2,2),prod_(2,2)
9459
9460       if (transp) then
9461 crc        call transpose2(kk(1,1),auxmat(1,1))
9462 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9463 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9464
9465            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9466      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9467            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9468      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9469            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9470      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9471            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9472      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9473
9474       else
9475 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9476 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9477
9478            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9479      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9480            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9481      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9482            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9483      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9484            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9485      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9486
9487       endif
9488 c      call transpose2(a2(1,1),a2t(1,1))
9489
9490 crc      print *,transp
9491 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9492 crc      print *,((prod(i,j),i=1,2),j=1,2)
9493
9494       return
9495       end
9496