source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       call flush(iout)
  31       if (nfgtasks.gt.1) then
  32 #ifdef MPI
  33         time00=MPI_Wtime()
  34 #else
  35         time00=tcpu()
  36 #endif
  37 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  38         if (fg_rank.eq.0) then
  39           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  40 c          print *,"Processor",myrank," BROADCAST iorder"
  41 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  42 C FG slaves as WEIGHTS array.
  43           weights_(1)=wsc
  44           weights_(2)=wscp
  45           weights_(3)=welec
  46           weights_(4)=wcorr
  47           weights_(5)=wcorr5
  48           weights_(6)=wcorr6
  49           weights_(7)=wel_loc
  50           weights_(8)=wturn3
  51           weights_(9)=wturn4
  52           weights_(10)=wturn6
  53           weights_(11)=wang
  54           weights_(12)=wscloc
  55           weights_(13)=wtor
  56           weights_(14)=wtor_d
  57           weights_(15)=wstrain
  58           weights_(16)=wvdwpp
  59           weights_(17)=wbond
  60           weights_(18)=scal14
  61           weights_(21)=wsccor
  62           weights_(22)=wsct
  63 C FG Master broadcasts the WEIGHTS_ array
  64           call MPI_Bcast(weights_(1),n_ene,
  65      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  66         else
  67 C FG slaves receive the WEIGHTS array
  68           call MPI_Bcast(weights(1),n_ene,
  69      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  70           wsc=weights(1)
  71           wscp=weights(2)
  72           welec=weights(3)
  73           wcorr=weights(4)
  74           wcorr5=weights(5)
  75           wcorr6=weights(6)
  76           wel_loc=weights(7)
  77           wturn3=weights(8)
  78           wturn4=weights(9)
  79           wturn6=weights(10)
  80           wang=weights(11)
  81           wscloc=weights(12)
  82           wtor=weights(13)
  83           wtor_d=weights(14)
  84           wstrain=weights(15)
  85           wvdwpp=weights(16)
  86           wbond=weights(17)
  87           scal14=weights(18)
  88           wsccor=weights(21)
  89           wsct=weights(22)
  90         endif
  91         time_Bcast=time_Bcast+MPI_Wtime()-time00
  92         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  93 c        call chainbuild_cart
  94       endif
  95 c      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)=
5993      &        0.5d0*waga_dist(iset)*distance(k)**2*sigma_odl(k,ii)
5994          enddo
5995
5996          min_odl=minval(distancek)
5997 #ifdef DEBUG
5998          write (iout,*) "ij dij",i,j,dij
5999          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6000          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6001          write (iout,* )"min_odl",min_odl
6002 #endif
6003          odleg2=0.0d0
6004          do k=1,constr_homology
6005 c Nie wiem po co to liczycie jeszcze raz!
6006 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6007 c     &              (2*(sigma_odl(i,j,k))**2))
6008             godl(k)=dexp(-distancek(k)+min_odl)
6009             odleg2=odleg2+godl(k)
6010
6011 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6012 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6013 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6014 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6015
6016          enddo
6017 #ifdef DEBUG
6018          write (iout,*) "godl",(godl(k),k=1,constr_homology)
6019          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2
6020 #endif
6021          odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6022 c Gradient
6023          sum_godl=odleg2
6024          sum_sgodl=0.0
6025          do k=1,constr_homology
6026 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6027 c     &           *waga_dist(iset))+min_odl
6028            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist(iset)
6029            sum_sgodl=sum_sgodl+sgodl
6030
6031 c            sgodl2=sgodl2+sgodl
6032 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6033 c      write(iout,*) "constr_homology=",constr_homology
6034 c      write(iout,*) i, j, k, "TEST K"
6035          enddo
6036
6037          grad_odl3=sum_sgodl/(sum_godl*dij)
6038
6039
6040 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6041 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6042 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6043
6044 ccc      write(iout,*) godl, sgodl, grad_odl3
6045
6046 c          grad_odl=grad_odl+grad_odl3
6047
6048          do jik=1,3
6049             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
6050 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6051 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6052 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6053             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
6054             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
6055 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6056 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6057
6058          enddo
6059 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
6060 ccc     & dLOG(odleg2),"-odleg=", -odleg
6061
6062       enddo ! ii
6063 c Pseudo-energy and gradient from dihedral-angle restraints from
6064 c homology templates
6065 c      write (iout,*) "End of distance loop"
6066 c      call flush(iout)
6067       kat=0.0d0
6068 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6069       do i=idihconstr_start_homo,idihconstr_end_homo
6070         kat2=0.0d0
6071 c        betai=beta(i,i+1,i+2,i+3)
6072         betai = phi(i+3)
6073         do k=1,constr_homology
6074           dih_diff(k)=pinorm(dih(k,i)-betai)
6075 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6076 c     &                                   -(6.28318-dih_diff(i,k))
6077 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6078 c     &                                   6.28318+dih_diff(i,k)
6079
6080           kat3=-0.5d0*waga_angle(iset)*dih_diff(k)**2*sigma_dih(k,i)
6081           gdih(k)=dexp(kat3)
6082           kat2=kat2+gdih(k)
6083 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
6084 c          write(*,*)""
6085         enddo
6086 #ifdef DEBUG
6087         write (iout,*) "i",i," betai",betai," kat2",kat2
6088         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6089 #endif
6090         if (kat2.le.1.0d-14) cycle
6091         kat=kat-dLOG(kat2/constr_homology)
6092
6093 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6094 ccc     & dLOG(kat2), "-kat=", -kat
6095
6096 c ----------------------------------------------------------------------
6097 c Gradient
6098 c ----------------------------------------------------------------------
6099
6100         sum_gdih=kat2
6101         sum_sgdih=0.0
6102         do k=1,constr_homology
6103           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle(iset)
6104           sum_sgdih=sum_sgdih+sgdih
6105         enddo
6106         grad_dih3=sum_sgdih/sum_gdih
6107
6108 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6109 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6110 ccc     & gloc(nphi+i-3,icg)
6111         gloc(i,icg)=gloc(i,icg)+grad_dih3
6112 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6113 ccc     & gloc(nphi+i-3,icg)
6114
6115       enddo
6116
6117
6118 c Total energy from homology restraints
6119 #ifdef DEBUG
6120       write (iout,*) "odleg",odleg," kat",kat
6121 #endif
6122       ehomology_constr=odleg+kat
6123       return
6124
6125   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6126   747 format(a12,i4,i4,i4,f8.3,f8.3)
6127   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6128   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6129   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6130      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6131       end
6132
6133 c------------------------------------------------------------------------------
6134       subroutine etor_d(etors_d)
6135 C 6/23/01 Compute double torsional energy
6136       implicit real*8 (a-h,o-z)
6137       include 'DIMENSIONS'
6138       include 'COMMON.VAR'
6139       include 'COMMON.GEO'
6140       include 'COMMON.LOCAL'
6141       include 'COMMON.TORSION'
6142       include 'COMMON.INTERACT'
6143       include 'COMMON.DERIV'
6144       include 'COMMON.CHAIN'
6145       include 'COMMON.NAMES'
6146       include 'COMMON.IOUNITS'
6147       include 'COMMON.FFIELD'
6148       include 'COMMON.TORCNSTR'
6149       logical lprn
6150 C Set lprn=.true. for debugging
6151       lprn=.false.
6152 c     lprn=.true.
6153       etors_d=0.0D0
6154       do i=iphid_start,iphid_end
6155         itori=itortyp(itype(i-2))
6156         itori1=itortyp(itype(i-1))
6157         itori2=itortyp(itype(i))
6158         phii=phi(i)
6159         phii1=phi(i+1)
6160         gloci1=0.0D0
6161         gloci2=0.0D0
6162         do j=1,ntermd_1(itori,itori1,itori2)
6163           v1cij=v1c(1,j,itori,itori1,itori2)
6164           v1sij=v1s(1,j,itori,itori1,itori2)
6165           v2cij=v1c(2,j,itori,itori1,itori2)
6166           v2sij=v1s(2,j,itori,itori1,itori2)
6167           cosphi1=dcos(j*phii)
6168           sinphi1=dsin(j*phii)
6169           cosphi2=dcos(j*phii1)
6170           sinphi2=dsin(j*phii1)
6171           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6172      &     v2cij*cosphi2+v2sij*sinphi2
6173           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6174           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6175         enddo
6176         do k=2,ntermd_2(itori,itori1,itori2)
6177           do l=1,k-1
6178             v1cdij = v2c(k,l,itori,itori1,itori2)
6179             v2cdij = v2c(l,k,itori,itori1,itori2)
6180             v1sdij = v2s(k,l,itori,itori1,itori2)
6181             v2sdij = v2s(l,k,itori,itori1,itori2)
6182             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6183             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6184             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6185             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6186             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6187      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6188             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6189      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6190             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6191      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6192           enddo
6193         enddo
6194         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6195         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6196 c        write (iout,*) "gloci", gloc(i-3,icg)
6197       enddo
6198       return
6199       end
6200 #endif
6201 c------------------------------------------------------------------------------
6202       subroutine eback_sc_corr(esccor)
6203 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6204 c        conformational states; temporarily implemented as differences
6205 c        between UNRES torsional potentials (dependent on three types of
6206 c        residues) and the torsional potentials dependent on all 20 types
6207 c        of residues computed from AM1  energy surfaces of terminally-blocked
6208 c        amino-acid residues.
6209       implicit real*8 (a-h,o-z)
6210       include 'DIMENSIONS'
6211       include 'COMMON.VAR'
6212       include 'COMMON.GEO'
6213       include 'COMMON.LOCAL'
6214       include 'COMMON.TORSION'
6215       include 'COMMON.SCCOR'
6216       include 'COMMON.INTERACT'
6217       include 'COMMON.DERIV'
6218       include 'COMMON.CHAIN'
6219       include 'COMMON.NAMES'
6220       include 'COMMON.IOUNITS'
6221       include 'COMMON.FFIELD'
6222       include 'COMMON.CONTROL'
6223       logical lprn
6224 C Set lprn=.true. for debugging
6225       lprn=.false.
6226 c      lprn=.true.
6227 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6228       esccor=0.0D0
6229       do i=itau_start,itau_end
6230         esccor_ii=0.0D0
6231         isccori=isccortyp(itype(i-2))
6232         isccori1=isccortyp(itype(i-1))
6233         phii=phi(i)
6234 cccc  Added 9 May 2012
6235 cc Tauangle is torsional engle depending on the value of first digit
6236 c(see comment below)
6237 cc Omicron is flat angle depending on the value of first digit
6238 c(see comment below)
6239
6240
6241         do intertyp=1,3 !intertyp
6242 cc Added 09 May 2012 (Adasko)
6243 cc  Intertyp means interaction type of backbone mainchain correlation:
6244 c   1 = SC...Ca...Ca...Ca
6245 c   2 = Ca...Ca...Ca...SC
6246 c   3 = SC...Ca...Ca...SCi
6247         gloci=0.0D0
6248         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6249      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6250      &      (itype(i-1).eq.21)))
6251      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6252      &     .or.(itype(i-2).eq.21)))
6253      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6254      &      (itype(i-1).eq.21)))) cycle
6255         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6256         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6257      & cycle
6258         do j=1,nterm_sccor(isccori,isccori1)
6259           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6260           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6261           cosphi=dcos(j*tauangle(intertyp,i))
6262           sinphi=dsin(j*tauangle(intertyp,i))
6263           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6264           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6265         enddo
6266         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6267 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6268 c     &gloc_sc(intertyp,i-3,icg)
6269         if (lprn)
6270      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6271      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6272      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6273      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6274         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6275        enddo !intertyp
6276       enddo
6277 c        do i=1,nres
6278 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6279 c        enddo
6280       return
6281       end
6282 c----------------------------------------------------------------------------
6283       subroutine multibody(ecorr)
6284 C This subroutine calculates multi-body contributions to energy following
6285 C the idea of Skolnick et al. If side chains I and J make a contact and
6286 C at the same time side chains I+1 and J+1 make a contact, an extra
6287 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6288       implicit real*8 (a-h,o-z)
6289       include 'DIMENSIONS'
6290       include 'COMMON.IOUNITS'
6291       include 'COMMON.DERIV'
6292       include 'COMMON.INTERACT'
6293       include 'COMMON.CONTACTS'
6294       double precision gx(3),gx1(3)
6295       logical lprn
6296
6297 C Set lprn=.true. for debugging
6298       lprn=.false.
6299
6300       if (lprn) then
6301         write (iout,'(a)') 'Contact function values:'
6302         do i=nnt,nct-2
6303           write (iout,'(i2,20(1x,i2,f10.5))')
6304      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6305         enddo
6306       endif
6307       ecorr=0.0D0
6308       do i=nnt,nct
6309         do j=1,3
6310           gradcorr(j,i)=0.0D0
6311           gradxorr(j,i)=0.0D0
6312         enddo
6313       enddo
6314       do i=nnt,nct-2
6315
6316         DO ISHIFT = 3,4
6317
6318         i1=i+ishift
6319         num_conti=num_cont(i)
6320         num_conti1=num_cont(i1)
6321         do jj=1,num_conti
6322           j=jcont(jj,i)
6323           do kk=1,num_conti1
6324             j1=jcont(kk,i1)
6325             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6326 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6327 cd   &                   ' ishift=',ishift
6328 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6329 C The system gains extra energy.
6330               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6331             endif   ! j1==j+-ishift
6332           enddo     ! kk
6333         enddo       ! jj
6334
6335         ENDDO ! ISHIFT
6336
6337       enddo         ! i
6338       return
6339       end
6340 c------------------------------------------------------------------------------
6341       double precision function esccorr(i,j,k,l,jj,kk)
6342       implicit real*8 (a-h,o-z)
6343       include 'DIMENSIONS'
6344       include 'COMMON.IOUNITS'
6345       include 'COMMON.DERIV'
6346       include 'COMMON.INTERACT'
6347       include 'COMMON.CONTACTS'
6348       double precision gx(3),gx1(3)
6349       logical lprn
6350       lprn=.false.
6351       eij=facont(jj,i)
6352       ekl=facont(kk,k)
6353 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6354 C Calculate the multi-body contribution to energy.
6355 C Calculate multi-body contributions to the gradient.
6356 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6357 cd   & k,l,(gacont(m,kk,k),m=1,3)
6358       do m=1,3
6359         gx(m) =ekl*gacont(m,jj,i)
6360         gx1(m)=eij*gacont(m,kk,k)
6361         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6362         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6363         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6364         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6365       enddo
6366       do m=i,j-1
6367         do ll=1,3
6368           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6369         enddo
6370       enddo
6371       do m=k,l-1
6372         do ll=1,3
6373           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6374         enddo
6375       enddo
6376       esccorr=-eij*ekl
6377       return
6378       end
6379 c------------------------------------------------------------------------------
6380       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6381 C This subroutine calculates multi-body contributions to hydrogen-bonding
6382       implicit real*8 (a-h,o-z)
6383       include 'DIMENSIONS'
6384       include 'COMMON.IOUNITS'
6385 #ifdef MPI
6386       include "mpif.h"
6387       parameter (max_cont=maxconts)
6388       parameter (max_dim=26)
6389       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6390       double precision zapas(max_dim,maxconts,max_fg_procs),
6391      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6392       common /przechowalnia/ zapas
6393       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6394      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6395 #endif
6396       include 'COMMON.SETUP'
6397       include 'COMMON.FFIELD'
6398       include 'COMMON.DERIV'
6399       include 'COMMON.INTERACT'
6400       include 'COMMON.CONTACTS'
6401       include 'COMMON.CONTROL'
6402       include 'COMMON.LOCAL'
6403       double precision gx(3),gx1(3),time00
6404       logical lprn,ldone
6405
6406 C Set lprn=.true. for debugging
6407       lprn=.false.
6408 #ifdef MPI
6409       n_corr=0
6410       n_corr1=0
6411       if (nfgtasks.le.1) goto 30
6412       if (lprn) then
6413         write (iout,'(a)') 'Contact function values before RECEIVE:'
6414         do i=nnt,nct-2
6415           write (iout,'(2i3,50(1x,i2,f5.2))')
6416      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6417      &    j=1,num_cont_hb(i))
6418         enddo
6419       endif
6420       call flush(iout)
6421       do i=1,ntask_cont_from
6422         ncont_recv(i)=0
6423       enddo
6424       do i=1,ntask_cont_to
6425         ncont_sent(i)=0
6426       enddo
6427 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6428 c     & ntask_cont_to
6429 C Make the list of contacts to send to send to other procesors
6430 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6431 c      call flush(iout)
6432       do i=iturn3_start,iturn3_end
6433 c        write (iout,*) "make contact list turn3",i," num_cont",
6434 c     &    num_cont_hb(i)
6435         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6436       enddo
6437       do i=iturn4_start,iturn4_end
6438 c        write (iout,*) "make contact list turn4",i," num_cont",
6439 c     &   num_cont_hb(i)
6440         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6441       enddo
6442       do ii=1,nat_sent
6443         i=iat_sent(ii)
6444 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6445 c     &    num_cont_hb(i)
6446         do j=1,num_cont_hb(i)
6447         do k=1,4
6448           jjc=jcont_hb(j,i)
6449           iproc=iint_sent_local(k,jjc,ii)
6450 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6451           if (iproc.gt.0) then
6452             ncont_sent(iproc)=ncont_sent(iproc)+1
6453             nn=ncont_sent(iproc)
6454             zapas(1,nn,iproc)=i
6455             zapas(2,nn,iproc)=jjc
6456             zapas(3,nn,iproc)=facont_hb(j,i)
6457             zapas(4,nn,iproc)=ees0p(j,i)
6458             zapas(5,nn,iproc)=ees0m(j,i)
6459             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6460             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6461             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6462             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6463             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6464             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6465             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6466             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6467             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6468             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6469             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6470             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6471             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6472             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6473             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6474             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6475             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6476             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6477             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6478             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6479             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6480           endif
6481         enddo
6482         enddo
6483       enddo
6484       if (lprn) then
6485       write (iout,*)
6486      &  "Numbers of contacts to be sent to other processors",
6487      &  (ncont_sent(i),i=1,ntask_cont_to)
6488       write (iout,*) "Contacts sent"
6489       do ii=1,ntask_cont_to
6490         nn=ncont_sent(ii)
6491         iproc=itask_cont_to(ii)
6492         write (iout,*) nn," contacts to processor",iproc,
6493      &   " of CONT_TO_COMM group"
6494         do i=1,nn
6495           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6496         enddo
6497       enddo
6498       call flush(iout)
6499       endif
6500       CorrelType=477
6501       CorrelID=fg_rank+1
6502       CorrelType1=478
6503       CorrelID1=nfgtasks+fg_rank+1
6504       ireq=0
6505 C Receive the numbers of needed contacts from other processors
6506       do ii=1,ntask_cont_from
6507         iproc=itask_cont_from(ii)
6508         ireq=ireq+1
6509         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6510      &    FG_COMM,req(ireq),IERR)
6511       enddo
6512 c      write (iout,*) "IRECV ended"
6513 c      call flush(iout)
6514 C Send the number of contacts needed by other processors
6515       do ii=1,ntask_cont_to
6516         iproc=itask_cont_to(ii)
6517         ireq=ireq+1
6518         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6519      &    FG_COMM,req(ireq),IERR)
6520       enddo
6521 c      write (iout,*) "ISEND ended"
6522 c      write (iout,*) "number of requests (nn)",ireq
6523       call flush(iout)
6524       if (ireq.gt.0)
6525      &  call MPI_Waitall(ireq,req,status_array,ierr)
6526 c      write (iout,*)
6527 c     &  "Numbers of contacts to be received from other processors",
6528 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6529 c      call flush(iout)
6530 C Receive contacts
6531       ireq=0
6532       do ii=1,ntask_cont_from
6533         iproc=itask_cont_from(ii)
6534         nn=ncont_recv(ii)
6535 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6536 c     &   " of CONT_TO_COMM group"
6537         call flush(iout)
6538         if (nn.gt.0) then
6539           ireq=ireq+1
6540           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6541      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6542 c          write (iout,*) "ireq,req",ireq,req(ireq)
6543         endif
6544       enddo
6545 C Send the contacts to processors that need them
6546       do ii=1,ntask_cont_to
6547         iproc=itask_cont_to(ii)
6548         nn=ncont_sent(ii)
6549 c        write (iout,*) nn," contacts to processor",iproc,
6550 c     &   " of CONT_TO_COMM group"
6551         if (nn.gt.0) then
6552           ireq=ireq+1
6553           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6554      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6555 c          write (iout,*) "ireq,req",ireq,req(ireq)
6556 c          do i=1,nn
6557 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6558 c          enddo
6559         endif
6560       enddo
6561 c      write (iout,*) "number of requests (contacts)",ireq
6562 c      write (iout,*) "req",(req(i),i=1,4)
6563 c      call flush(iout)
6564       if (ireq.gt.0)
6565      & call MPI_Waitall(ireq,req,status_array,ierr)
6566       do iii=1,ntask_cont_from
6567         iproc=itask_cont_from(iii)
6568         nn=ncont_recv(iii)
6569         if (lprn) then
6570         write (iout,*) "Received",nn," contacts from processor",iproc,
6571      &   " of CONT_FROM_COMM group"
6572         call flush(iout)
6573         do i=1,nn
6574           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6575         enddo
6576         call flush(iout)
6577         endif
6578         do i=1,nn
6579           ii=zapas_recv(1,i,iii)
6580 c Flag the received contacts to prevent double-counting
6581           jj=-zapas_recv(2,i,iii)
6582 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6583 c          call flush(iout)
6584           nnn=num_cont_hb(ii)+1
6585           num_cont_hb(ii)=nnn
6586           jcont_hb(nnn,ii)=jj
6587           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6588           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6589           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6590           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6591           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6592           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6593           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6594           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6595           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6596           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6597           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6598           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6599           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6600           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6601           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6602           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6603           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6604           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6605           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6606           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6607           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6608           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6609           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6610           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6611         enddo
6612       enddo
6613       call flush(iout)
6614       if (lprn) then
6615         write (iout,'(a)') 'Contact function values after receive:'
6616         do i=nnt,nct-2
6617           write (iout,'(2i3,50(1x,i3,f5.2))')
6618      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6619      &    j=1,num_cont_hb(i))
6620         enddo
6621         call flush(iout)
6622       endif
6623    30 continue
6624 #endif
6625       if (lprn) then
6626         write (iout,'(a)') 'Contact function values:'
6627         do i=nnt,nct-2
6628           write (iout,'(2i3,50(1x,i3,f5.2))')
6629      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6630      &    j=1,num_cont_hb(i))
6631         enddo
6632       endif
6633       ecorr=0.0D0
6634 C Remove the loop below after debugging !!!
6635       do i=nnt,nct
6636         do j=1,3
6637           gradcorr(j,i)=0.0D0
6638           gradxorr(j,i)=0.0D0
6639         enddo
6640       enddo
6641 C Calculate the local-electrostatic correlation terms
6642       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6643         i1=i+1
6644         num_conti=num_cont_hb(i)
6645         num_conti1=num_cont_hb(i+1)
6646         do jj=1,num_conti
6647           j=jcont_hb(jj,i)
6648           jp=iabs(j)
6649           do kk=1,num_conti1
6650             j1=jcont_hb(kk,i1)
6651             jp1=iabs(j1)
6652 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6653 c     &         ' jj=',jj,' kk=',kk
6654             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6655      &          .or. j.lt.0 .and. j1.gt.0) .and.
6656      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6657 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6658 C The system gains extra energy.
6659               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6660               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6661      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6662               n_corr=n_corr+1
6663             else if (j1.eq.j) then
6664 C Contacts I-J and I-(J+1) occur simultaneously.
6665 C The system loses extra energy.
6666 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6667             endif
6668           enddo ! kk
6669           do kk=1,num_conti
6670             j1=jcont_hb(kk,i)
6671 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6672 c    &         ' jj=',jj,' kk=',kk
6673             if (j1.eq.j+1) then
6674 C Contacts I-J and (I+1)-J occur simultaneously.
6675 C The system loses extra energy.
6676 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6677             endif ! j1==j+1
6678           enddo ! kk
6679         enddo ! jj
6680       enddo ! i
6681       return
6682       end
6683 c------------------------------------------------------------------------------
6684       subroutine add_hb_contact(ii,jj,itask)
6685       implicit real*8 (a-h,o-z)
6686       include "DIMENSIONS"
6687       include "COMMON.IOUNITS"
6688       integer max_cont
6689       integer max_dim
6690       parameter (max_cont=maxconts)
6691       parameter (max_dim=26)
6692       include "COMMON.CONTACTS"
6693       double precision zapas(max_dim,maxconts,max_fg_procs),
6694      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6695       common /przechowalnia/ zapas
6696       integer i,j,ii,jj,iproc,itask(4),nn
6697 c      write (iout,*) "itask",itask
6698       do i=1,2
6699         iproc=itask(i)
6700         if (iproc.gt.0) then
6701           do j=1,num_cont_hb(ii)
6702             jjc=jcont_hb(j,ii)
6703 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6704             if (jjc.eq.jj) then
6705               ncont_sent(iproc)=ncont_sent(iproc)+1
6706               nn=ncont_sent(iproc)
6707               zapas(1,nn,iproc)=ii
6708               zapas(2,nn,iproc)=jjc
6709               zapas(3,nn,iproc)=facont_hb(j,ii)
6710               zapas(4,nn,iproc)=ees0p(j,ii)
6711               zapas(5,nn,iproc)=ees0m(j,ii)
6712               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6713               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6714               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6715               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6716               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6717               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6718               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6719               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6720               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6721               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6722               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6723               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6724               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6725               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6726               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6727               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6728               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6729               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6730               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6731               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6732               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6733               exit
6734             endif
6735           enddo
6736         endif
6737       enddo
6738       return
6739       end
6740 c------------------------------------------------------------------------------
6741       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6742      &  n_corr1)
6743 C This subroutine calculates multi-body contributions to hydrogen-bonding
6744       implicit real*8 (a-h,o-z)
6745       include 'DIMENSIONS'
6746       include 'COMMON.IOUNITS'
6747 #ifdef MPI
6748       include "mpif.h"
6749       parameter (max_cont=maxconts)
6750       parameter (max_dim=70)
6751       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6752       double precision zapas(max_dim,maxconts,max_fg_procs),
6753      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6754       common /przechowalnia/ zapas
6755       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6756      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6757 #endif
6758       include 'COMMON.SETUP'
6759       include 'COMMON.FFIELD'
6760       include 'COMMON.DERIV'
6761       include 'COMMON.LOCAL'
6762       include 'COMMON.INTERACT'
6763       include 'COMMON.CONTACTS'
6764       include 'COMMON.CHAIN'
6765       include 'COMMON.CONTROL'
6766       double precision gx(3),gx1(3)
6767       integer num_cont_hb_old(maxres)
6768       logical lprn,ldone
6769       double precision eello4,eello5,eelo6,eello_turn6
6770       external eello4,eello5,eello6,eello_turn6
6771 C Set lprn=.true. for debugging
6772       lprn=.false.
6773       eturn6=0.0d0
6774 #ifdef MPI
6775       do i=1,nres
6776         num_cont_hb_old(i)=num_cont_hb(i)
6777       enddo
6778       n_corr=0
6779       n_corr1=0
6780       if (nfgtasks.le.1) goto 30
6781       if (lprn) then
6782         write (iout,'(a)') 'Contact function values before RECEIVE:'
6783         do i=nnt,nct-2
6784           write (iout,'(2i3,50(1x,i2,f5.2))')
6785      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6786      &    j=1,num_cont_hb(i))
6787         enddo
6788       endif
6789       call flush(iout)
6790       do i=1,ntask_cont_from
6791         ncont_recv(i)=0
6792       enddo
6793       do i=1,ntask_cont_to
6794         ncont_sent(i)=0
6795       enddo
6796 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6797 c     & ntask_cont_to
6798 C Make the list of contacts to send to send to other procesors
6799       do i=iturn3_start,iturn3_end
6800 c        write (iout,*) "make contact list turn3",i," num_cont",
6801 c     &    num_cont_hb(i)
6802         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6803       enddo
6804       do i=iturn4_start,iturn4_end
6805 c        write (iout,*) "make contact list turn4",i," num_cont",
6806 c     &   num_cont_hb(i)
6807         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6808       enddo
6809       do ii=1,nat_sent
6810         i=iat_sent(ii)
6811 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6812 c     &    num_cont_hb(i)
6813         do j=1,num_cont_hb(i)
6814         do k=1,4
6815           jjc=jcont_hb(j,i)
6816           iproc=iint_sent_local(k,jjc,ii)
6817 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6818           if (iproc.ne.0) then
6819             ncont_sent(iproc)=ncont_sent(iproc)+1
6820             nn=ncont_sent(iproc)
6821             zapas(1,nn,iproc)=i
6822             zapas(2,nn,iproc)=jjc
6823             zapas(3,nn,iproc)=d_cont(j,i)
6824             ind=3
6825             do kk=1,3
6826               ind=ind+1
6827               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6828             enddo
6829             do kk=1,2
6830               do ll=1,2
6831                 ind=ind+1
6832                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6833               enddo
6834             enddo
6835             do jj=1,5
6836               do kk=1,3
6837                 do ll=1,2
6838                   do mm=1,2
6839                     ind=ind+1
6840                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6841                   enddo
6842                 enddo
6843               enddo
6844             enddo
6845           endif
6846         enddo
6847         enddo
6848       enddo
6849       if (lprn) then
6850       write (iout,*)
6851      &  "Numbers of contacts to be sent to other processors",
6852      &  (ncont_sent(i),i=1,ntask_cont_to)
6853       write (iout,*) "Contacts sent"
6854       do ii=1,ntask_cont_to
6855         nn=ncont_sent(ii)
6856         iproc=itask_cont_to(ii)
6857         write (iout,*) nn," contacts to processor",iproc,
6858      &   " of CONT_TO_COMM group"
6859         do i=1,nn
6860           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6861         enddo
6862       enddo
6863       call flush(iout)
6864       endif
6865       CorrelType=477
6866       CorrelID=fg_rank+1
6867       CorrelType1=478
6868       CorrelID1=nfgtasks+fg_rank+1
6869       ireq=0
6870 C Receive the numbers of needed contacts from other processors
6871       do ii=1,ntask_cont_from
6872         iproc=itask_cont_from(ii)
6873         ireq=ireq+1
6874         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6875      &    FG_COMM,req(ireq),IERR)
6876       enddo
6877 c      write (iout,*) "IRECV ended"
6878 c      call flush(iout)
6879 C Send the number of contacts needed by other processors
6880       do ii=1,ntask_cont_to
6881         iproc=itask_cont_to(ii)
6882         ireq=ireq+1
6883         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6884      &    FG_COMM,req(ireq),IERR)
6885       enddo
6886 c      write (iout,*) "ISEND ended"
6887 c      write (iout,*) "number of requests (nn)",ireq
6888       call flush(iout)
6889       if (ireq.gt.0)
6890      &  call MPI_Waitall(ireq,req,status_array,ierr)
6891 c      write (iout,*)
6892 c     &  "Numbers of contacts to be received from other processors",
6893 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6894 c      call flush(iout)
6895 C Receive contacts
6896       ireq=0
6897       do ii=1,ntask_cont_from
6898         iproc=itask_cont_from(ii)
6899         nn=ncont_recv(ii)
6900 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6901 c     &   " of CONT_TO_COMM group"
6902         call flush(iout)
6903         if (nn.gt.0) then
6904           ireq=ireq+1
6905           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6906      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6907 c          write (iout,*) "ireq,req",ireq,req(ireq)
6908         endif
6909       enddo
6910 C Send the contacts to processors that need them
6911       do ii=1,ntask_cont_to
6912         iproc=itask_cont_to(ii)
6913         nn=ncont_sent(ii)
6914 c        write (iout,*) nn," contacts to processor",iproc,
6915 c     &   " of CONT_TO_COMM group"
6916         if (nn.gt.0) then
6917           ireq=ireq+1
6918           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6919      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6920 c          write (iout,*) "ireq,req",ireq,req(ireq)
6921 c          do i=1,nn
6922 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6923 c          enddo
6924         endif
6925       enddo
6926 c      write (iout,*) "number of requests (contacts)",ireq
6927 c      write (iout,*) "req",(req(i),i=1,4)
6928 c      call flush(iout)
6929       if (ireq.gt.0)
6930      & call MPI_Waitall(ireq,req,status_array,ierr)
6931       do iii=1,ntask_cont_from
6932         iproc=itask_cont_from(iii)
6933         nn=ncont_recv(iii)
6934         if (lprn) then
6935         write (iout,*) "Received",nn," contacts from processor",iproc,
6936      &   " of CONT_FROM_COMM group"
6937         call flush(iout)
6938         do i=1,nn
6939           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6940         enddo
6941         call flush(iout)
6942         endif
6943         do i=1,nn
6944           ii=zapas_recv(1,i,iii)
6945 c Flag the received contacts to prevent double-counting
6946           jj=-zapas_recv(2,i,iii)
6947 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6948 c          call flush(iout)
6949           nnn=num_cont_hb(ii)+1
6950           num_cont_hb(ii)=nnn
6951           jcont_hb(nnn,ii)=jj
6952           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6953           ind=3
6954           do kk=1,3
6955             ind=ind+1
6956             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6957           enddo
6958           do kk=1,2
6959             do ll=1,2
6960               ind=ind+1
6961               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6962             enddo
6963           enddo
6964           do jj=1,5
6965             do kk=1,3
6966               do ll=1,2
6967                 do mm=1,2
6968                   ind=ind+1
6969                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6970                 enddo
6971               enddo
6972             enddo
6973           enddo
6974         enddo
6975       enddo
6976       call flush(iout)
6977       if (lprn) then
6978         write (iout,'(a)') 'Contact function values after receive:'
6979         do i=nnt,nct-2
6980           write (iout,'(2i3,50(1x,i3,5f6.3))')
6981      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6982      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6983         enddo
6984         call flush(iout)
6985       endif
6986    30 continue
6987 #endif
6988       if (lprn) then
6989         write (iout,'(a)') 'Contact function values:'
6990         do i=nnt,nct-2
6991           write (iout,'(2i3,50(1x,i2,5f6.3))')
6992      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6993      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6994         enddo
6995       endif
6996       ecorr=0.0D0
6997       ecorr5=0.0d0
6998       ecorr6=0.0d0
6999 C Remove the loop below after debugging !!!
7000       do i=nnt,nct
7001         do j=1,3
7002           gradcorr(j,i)=0.0D0
7003           gradxorr(j,i)=0.0D0
7004         enddo
7005       enddo
7006 C Calculate the dipole-dipole interaction energies
7007       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7008       do i=iatel_s,iatel_e+1
7009         num_conti=num_cont_hb(i)
7010         do jj=1,num_conti
7011           j=jcont_hb(jj,i)
7012 #ifdef MOMENT
7013           call dipole(i,j,jj)
7014 #endif
7015         enddo
7016       enddo
7017       endif
7018 C Calculate the local-electrostatic correlation terms
7019 c                write (iout,*) "gradcorr5 in eello5 before loop"
7020 c                do iii=1,nres
7021 c                  write (iout,'(i5,3f10.5)')
7022 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7023 c                enddo
7024       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7025 c        write (iout,*) "corr loop i",i
7026         i1=i+1
7027         num_conti=num_cont_hb(i)
7028         num_conti1=num_cont_hb(i+1)
7029         do jj=1,num_conti
7030           j=jcont_hb(jj,i)
7031           jp=iabs(j)
7032           do kk=1,num_conti1
7033             j1=jcont_hb(kk,i1)
7034             jp1=iabs(j1)
7035 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7036 c     &         ' jj=',jj,' kk=',kk
7037 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7038             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7039      &          .or. j.lt.0 .and. j1.gt.0) .and.
7040      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7041 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7042 C The system gains extra energy.
7043               n_corr=n_corr+1
7044               sqd1=dsqrt(d_cont(jj,i))
7045               sqd2=dsqrt(d_cont(kk,i1))
7046               sred_geom = sqd1*sqd2
7047               IF (sred_geom.lt.cutoff_corr) THEN
7048                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7049      &            ekont,fprimcont)
7050 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7051 cd     &         ' jj=',jj,' kk=',kk
7052                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7053                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7054                 do l=1,3
7055                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7056                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7057                 enddo
7058                 n_corr1=n_corr1+1
7059 cd               write (iout,*) 'sred_geom=',sred_geom,
7060 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7061 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7062 cd               write (iout,*) "g_contij",g_contij
7063 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7064 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7065                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7066                 if (wcorr4.gt.0.0d0)
7067      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7068                   if (energy_dec.and.wcorr4.gt.0.0d0)
7069      1                 write (iout,'(a6,4i5,0pf7.3)')
7070      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7071 c                write (iout,*) "gradcorr5 before eello5"
7072 c                do iii=1,nres
7073 c                  write (iout,'(i5,3f10.5)')
7074 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7075 c                enddo
7076                 if (wcorr5.gt.0.0d0)
7077      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7078 c                write (iout,*) "gradcorr5 after eello5"
7079 c                do iii=1,nres
7080 c                  write (iout,'(i5,3f10.5)')
7081 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7082 c                enddo
7083                   if (energy_dec.and.wcorr5.gt.0.0d0)
7084      1                 write (iout,'(a6,4i5,0pf7.3)')
7085      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7086 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7087 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7088                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7089      &               .or. wturn6.eq.0.0d0))then
7090 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7091                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7092                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7093      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7094 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7095 cd     &            'ecorr6=',ecorr6
7096 cd                write (iout,'(4e15.5)') sred_geom,
7097 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7098 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7099 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7100                 else if (wturn6.gt.0.0d0
7101      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7102 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7103                   eturn6=eturn6+eello_turn6(i,jj,kk)
7104                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7105      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7106 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7107                 endif
7108               ENDIF
7109 1111          continue
7110             endif
7111           enddo ! kk
7112         enddo ! jj
7113       enddo ! i
7114       do i=1,nres
7115         num_cont_hb(i)=num_cont_hb_old(i)
7116       enddo
7117 c                write (iout,*) "gradcorr5 in eello5"
7118 c                do iii=1,nres
7119 c                  write (iout,'(i5,3f10.5)')
7120 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7121 c                enddo
7122       return
7123       end
7124 c------------------------------------------------------------------------------
7125       subroutine add_hb_contact_eello(ii,jj,itask)
7126       implicit real*8 (a-h,o-z)
7127       include "DIMENSIONS"
7128       include "COMMON.IOUNITS"
7129       integer max_cont
7130       integer max_dim
7131       parameter (max_cont=maxconts)
7132       parameter (max_dim=70)
7133       include "COMMON.CONTACTS"
7134       double precision zapas(max_dim,maxconts,max_fg_procs),
7135      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7136       common /przechowalnia/ zapas
7137       integer i,j,ii,jj,iproc,itask(4),nn
7138 c      write (iout,*) "itask",itask
7139       do i=1,2
7140         iproc=itask(i)
7141         if (iproc.gt.0) then
7142           do j=1,num_cont_hb(ii)
7143             jjc=jcont_hb(j,ii)
7144 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7145             if (jjc.eq.jj) then
7146               ncont_sent(iproc)=ncont_sent(iproc)+1
7147               nn=ncont_sent(iproc)
7148               zapas(1,nn,iproc)=ii
7149               zapas(2,nn,iproc)=jjc
7150               zapas(3,nn,iproc)=d_cont(j,ii)
7151               ind=3
7152               do kk=1,3
7153                 ind=ind+1
7154                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7155               enddo
7156               do kk=1,2
7157                 do ll=1,2
7158                   ind=ind+1
7159                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7160                 enddo
7161               enddo
7162               do jj=1,5
7163                 do kk=1,3
7164                   do ll=1,2
7165                     do mm=1,2
7166                       ind=ind+1
7167                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7168                     enddo
7169                   enddo
7170                 enddo
7171               enddo
7172               exit
7173             endif
7174           enddo
7175         endif
7176       enddo
7177       return
7178       end
7179 c------------------------------------------------------------------------------
7180       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7181       implicit real*8 (a-h,o-z)
7182       include 'DIMENSIONS'
7183       include 'COMMON.IOUNITS'
7184       include 'COMMON.DERIV'
7185       include 'COMMON.INTERACT'
7186       include 'COMMON.CONTACTS'
7187       double precision gx(3),gx1(3)
7188       logical lprn
7189       lprn=.false.
7190       eij=facont_hb(jj,i)
7191       ekl=facont_hb(kk,k)
7192       ees0pij=ees0p(jj,i)
7193       ees0pkl=ees0p(kk,k)
7194       ees0mij=ees0m(jj,i)
7195       ees0mkl=ees0m(kk,k)
7196       ekont=eij*ekl
7197       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7198 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7199 C Following 4 lines for diagnostics.
7200 cd    ees0pkl=0.0D0
7201 cd    ees0pij=1.0D0
7202 cd    ees0mkl=0.0D0
7203 cd    ees0mij=1.0D0
7204 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7205 c     & 'Contacts ',i,j,
7206 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7207 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7208 c     & 'gradcorr_long'
7209 C Calculate the multi-body contribution to energy.
7210 c      ecorr=ecorr+ekont*ees
7211 C Calculate multi-body contributions to the gradient.
7212       coeffpees0pij=coeffp*ees0pij
7213       coeffmees0mij=coeffm*ees0mij
7214       coeffpees0pkl=coeffp*ees0pkl
7215       coeffmees0mkl=coeffm*ees0mkl
7216       do ll=1,3
7217 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7218         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7219      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7220      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7221         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7222      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7223      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7224 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7225         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7226      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7227      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7228         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7229      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7230      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7231         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7232      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7233      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7234         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7235         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7236         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7237      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7238      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7239         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7240         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7241 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7242       enddo
7243 c      write (iout,*)
7244 cgrad      do m=i+1,j-1
7245 cgrad        do ll=1,3
7246 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7247 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7248 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7249 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7250 cgrad        enddo
7251 cgrad      enddo
7252 cgrad      do m=k+1,l-1
7253 cgrad        do ll=1,3
7254 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7255 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7256 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7257 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7258 cgrad        enddo
7259 cgrad      enddo
7260 c      write (iout,*) "ehbcorr",ekont*ees
7261       ehbcorr=ekont*ees
7262       return
7263       end
7264 #ifdef MOMENT
7265 C---------------------------------------------------------------------------
7266       subroutine dipole(i,j,jj)
7267       implicit real*8 (a-h,o-z)
7268       include 'DIMENSIONS'
7269       include 'COMMON.IOUNITS'
7270       include 'COMMON.CHAIN'
7271       include 'COMMON.FFIELD'
7272       include 'COMMON.DERIV'
7273       include 'COMMON.INTERACT'
7274       include 'COMMON.CONTACTS'
7275       include 'COMMON.TORSION'
7276       include 'COMMON.VAR'
7277       include 'COMMON.GEO'
7278       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7279      &  auxmat(2,2)
7280       iti1 = itortyp(itype(i+1))
7281       if (j.lt.nres-1) then
7282         itj1 = itortyp(itype(j+1))
7283       else
7284         itj1=ntortyp+1
7285       endif
7286       do iii=1,2
7287         dipi(iii,1)=Ub2(iii,i)
7288         dipderi(iii)=Ub2der(iii,i)
7289         dipi(iii,2)=b1(iii,iti1)
7290         dipj(iii,1)=Ub2(iii,j)
7291         dipderj(iii)=Ub2der(iii,j)
7292         dipj(iii,2)=b1(iii,itj1)
7293       enddo
7294       kkk=0
7295       do iii=1,2
7296         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7297         do jjj=1,2
7298           kkk=kkk+1
7299           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7300         enddo
7301       enddo
7302       do kkk=1,5
7303         do lll=1,3
7304           mmm=0
7305           do iii=1,2
7306             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7307      &        auxvec(1))
7308             do jjj=1,2
7309               mmm=mmm+1
7310               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7311             enddo
7312           enddo
7313         enddo
7314       enddo
7315       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7316       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7317       do iii=1,2
7318         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7319       enddo
7320       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7321       do iii=1,2
7322         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7323       enddo
7324       return
7325       end
7326 #endif
7327 C---------------------------------------------------------------------------
7328       subroutine calc_eello(i,j,k,l,jj,kk)
7329 C
7330 C This subroutine computes matrices and vectors needed to calculate
7331 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7332 C
7333       implicit real*8 (a-h,o-z)
7334       include 'DIMENSIONS'
7335       include 'COMMON.IOUNITS'
7336       include 'COMMON.CHAIN'
7337       include 'COMMON.DERIV'
7338       include 'COMMON.INTERACT'
7339       include 'COMMON.CONTACTS'
7340       include 'COMMON.TORSION'
7341       include 'COMMON.VAR'
7342       include 'COMMON.GEO'
7343       include 'COMMON.FFIELD'
7344       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7345      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7346       logical lprn
7347       common /kutas/ lprn
7348 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7349 cd     & ' jj=',jj,' kk=',kk
7350 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7351 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7352 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7353       do iii=1,2
7354         do jjj=1,2
7355           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7356           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7357         enddo
7358       enddo
7359       call transpose2(aa1(1,1),aa1t(1,1))
7360       call transpose2(aa2(1,1),aa2t(1,1))
7361       do kkk=1,5
7362         do lll=1,3
7363           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7364      &      aa1tder(1,1,lll,kkk))
7365           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7366      &      aa2tder(1,1,lll,kkk))
7367         enddo
7368       enddo
7369       if (l.eq.j+1) then
7370 C parallel orientation of the two CA-CA-CA frames.
7371         if (i.gt.1) then
7372           iti=itortyp(itype(i))
7373         else
7374           iti=ntortyp+1
7375         endif
7376         itk1=itortyp(itype(k+1))
7377         itj=itortyp(itype(j))
7378         if (l.lt.nres-1) then
7379           itl1=itortyp(itype(l+1))
7380         else
7381           itl1=ntortyp+1
7382         endif
7383 C A1 kernel(j+1) A2T
7384 cd        do iii=1,2
7385 cd          write (iout,'(3f10.5,5x,3f10.5)')
7386 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7387 cd        enddo
7388         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7389      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7390      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7391 C Following matrices are needed only for 6-th order cumulants
7392         IF (wcorr6.gt.0.0d0) THEN
7393         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7394      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7395      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7396         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7397      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7398      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7399      &   ADtEAderx(1,1,1,1,1,1))
7400         lprn=.false.
7401         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7402      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7403      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7404      &   ADtEA1derx(1,1,1,1,1,1))
7405         ENDIF
7406 C End 6-th order cumulants
7407 cd        lprn=.false.
7408 cd        if (lprn) then
7409 cd        write (2,*) 'In calc_eello6'
7410 cd        do iii=1,2
7411 cd          write (2,*) 'iii=',iii
7412 cd          do kkk=1,5
7413 cd            write (2,*) 'kkk=',kkk
7414 cd            do jjj=1,2
7415 cd              write (2,'(3(2f10.5),5x)')
7416 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7417 cd            enddo
7418 cd          enddo
7419 cd        enddo
7420 cd        endif
7421         call transpose2(EUgder(1,1,k),auxmat(1,1))
7422         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7423         call transpose2(EUg(1,1,k),auxmat(1,1))
7424         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7425         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7426         do iii=1,2
7427           do kkk=1,5
7428             do lll=1,3
7429               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7430      &          EAEAderx(1,1,lll,kkk,iii,1))
7431             enddo
7432           enddo
7433         enddo
7434 C A1T kernel(i+1) A2
7435         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7436      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7437      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7438 C Following matrices are needed only for 6-th order cumulants
7439         IF (wcorr6.gt.0.0d0) THEN
7440         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7441      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7442      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7443         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7444      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7445      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7446      &   ADtEAderx(1,1,1,1,1,2))
7447         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7448      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7449      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7450      &   ADtEA1derx(1,1,1,1,1,2))
7451         ENDIF
7452 C End 6-th order cumulants
7453         call transpose2(EUgder(1,1,l),auxmat(1,1))
7454         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7455         call transpose2(EUg(1,1,l),auxmat(1,1))
7456         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7457         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7458         do iii=1,2
7459           do kkk=1,5
7460             do lll=1,3
7461               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7462      &          EAEAderx(1,1,lll,kkk,iii,2))
7463             enddo
7464           enddo
7465         enddo
7466 C AEAb1 and AEAb2
7467 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7468 C They are needed only when the fifth- or the sixth-order cumulants are
7469 C indluded.
7470         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7471         call transpose2(AEA(1,1,1),auxmat(1,1))
7472         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7473         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7474         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7475         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7476         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7477         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7478         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7479         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7480         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7481         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7482         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7483         call transpose2(AEA(1,1,2),auxmat(1,1))
7484         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7485         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7486         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7487         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7488         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7489         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7490         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7491         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7492         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7493         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7494         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7495 C Calculate the Cartesian derivatives of the vectors.
7496         do iii=1,2
7497           do kkk=1,5
7498             do lll=1,3
7499               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7500               call matvec2(auxmat(1,1),b1(1,iti),
7501      &          AEAb1derx(1,lll,kkk,iii,1,1))
7502               call matvec2(auxmat(1,1),Ub2(1,i),
7503      &          AEAb2derx(1,lll,kkk,iii,1,1))
7504               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7505      &          AEAb1derx(1,lll,kkk,iii,2,1))
7506               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7507      &          AEAb2derx(1,lll,kkk,iii,2,1))
7508               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7509               call matvec2(auxmat(1,1),b1(1,itj),
7510      &          AEAb1derx(1,lll,kkk,iii,1,2))
7511               call matvec2(auxmat(1,1),Ub2(1,j),
7512      &          AEAb2derx(1,lll,kkk,iii,1,2))
7513               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7514      &          AEAb1derx(1,lll,kkk,iii,2,2))
7515               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7516      &          AEAb2derx(1,lll,kkk,iii,2,2))
7517             enddo
7518           enddo
7519         enddo
7520         ENDIF
7521 C End vectors
7522       else
7523 C Antiparallel orientation of the two CA-CA-CA frames.
7524         if (i.gt.1) then
7525           iti=itortyp(itype(i))
7526         else
7527           iti=ntortyp+1
7528         endif
7529         itk1=itortyp(itype(k+1))
7530         itl=itortyp(itype(l))
7531         itj=itortyp(itype(j))
7532         if (j.lt.nres-1) then
7533           itj1=itortyp(itype(j+1))
7534         else
7535           itj1=ntortyp+1
7536         endif
7537 C A2 kernel(j-1)T A1T
7538         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7539      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7540      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7541 C Following matrices are needed only for 6-th order cumulants
7542         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7543      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7544         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7545      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7546      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7547         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7548      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7549      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7550      &   ADtEAderx(1,1,1,1,1,1))
7551         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7552      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7553      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7554      &   ADtEA1derx(1,1,1,1,1,1))
7555         ENDIF
7556 C End 6-th order cumulants
7557         call transpose2(EUgder(1,1,k),auxmat(1,1))
7558         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7559         call transpose2(EUg(1,1,k),auxmat(1,1))
7560         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7561         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7562         do iii=1,2
7563           do kkk=1,5
7564             do lll=1,3
7565               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7566      &          EAEAderx(1,1,lll,kkk,iii,1))
7567             enddo
7568           enddo
7569         enddo
7570 C A2T kernel(i+1)T A1
7571         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7572      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7573      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7574 C Following matrices are needed only for 6-th order cumulants
7575         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7576      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7577         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7578      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7579      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7580         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7581      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7582      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7583      &   ADtEAderx(1,1,1,1,1,2))
7584         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7585      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7586      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7587      &   ADtEA1derx(1,1,1,1,1,2))
7588         ENDIF
7589 C End 6-th order cumulants
7590         call transpose2(EUgder(1,1,j),auxmat(1,1))
7591         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7592         call transpose2(EUg(1,1,j),auxmat(1,1))
7593         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7594         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7595         do iii=1,2
7596           do kkk=1,5
7597             do lll=1,3
7598               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7599      &          EAEAderx(1,1,lll,kkk,iii,2))
7600             enddo
7601           enddo
7602         enddo
7603 C AEAb1 and AEAb2
7604 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7605 C They are needed only when the fifth- or the sixth-order cumulants are
7606 C indluded.
7607         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7608      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7609         call transpose2(AEA(1,1,1),auxmat(1,1))
7610         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7611         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7612         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7613         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7614         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7615         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7616         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7617         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7618         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7619         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7620         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7621         call transpose2(AEA(1,1,2),auxmat(1,1))
7622         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7623         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7624         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7625         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7626         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7627         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7628         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7629         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7630         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7631         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7632         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7633 C Calculate the Cartesian derivatives of the vectors.
7634         do iii=1,2
7635           do kkk=1,5
7636             do lll=1,3
7637               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7638               call matvec2(auxmat(1,1),b1(1,iti),
7639      &          AEAb1derx(1,lll,kkk,iii,1,1))
7640               call matvec2(auxmat(1,1),Ub2(1,i),
7641      &          AEAb2derx(1,lll,kkk,iii,1,1))
7642               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7643      &          AEAb1derx(1,lll,kkk,iii,2,1))
7644               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7645      &          AEAb2derx(1,lll,kkk,iii,2,1))
7646               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7647               call matvec2(auxmat(1,1),b1(1,itl),
7648      &          AEAb1derx(1,lll,kkk,iii,1,2))
7649               call matvec2(auxmat(1,1),Ub2(1,l),
7650      &          AEAb2derx(1,lll,kkk,iii,1,2))
7651               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7652      &          AEAb1derx(1,lll,kkk,iii,2,2))
7653               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7654      &          AEAb2derx(1,lll,kkk,iii,2,2))
7655             enddo
7656           enddo
7657         enddo
7658         ENDIF
7659 C End vectors
7660       endif
7661       return
7662       end
7663 C---------------------------------------------------------------------------
7664       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7665      &  KK,KKderg,AKA,AKAderg,AKAderx)
7666       implicit none
7667       integer nderg
7668       logical transp
7669       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7670      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7671      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7672       integer iii,kkk,lll
7673       integer jjj,mmm
7674       logical lprn
7675       common /kutas/ lprn
7676       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7677       do iii=1,nderg
7678         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7679      &    AKAderg(1,1,iii))
7680       enddo
7681 cd      if (lprn) write (2,*) 'In kernel'
7682       do kkk=1,5
7683 cd        if (lprn) write (2,*) 'kkk=',kkk
7684         do lll=1,3
7685           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7686      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7687 cd          if (lprn) then
7688 cd            write (2,*) 'lll=',lll
7689 cd            write (2,*) 'iii=1'
7690 cd            do jjj=1,2
7691 cd              write (2,'(3(2f10.5),5x)')
7692 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7693 cd            enddo
7694 cd          endif
7695           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7696      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7697 cd          if (lprn) then
7698 cd            write (2,*) 'lll=',lll
7699 cd            write (2,*) 'iii=2'
7700 cd            do jjj=1,2
7701 cd              write (2,'(3(2f10.5),5x)')
7702 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7703 cd            enddo
7704 cd          endif
7705         enddo
7706       enddo
7707       return
7708       end
7709 C---------------------------------------------------------------------------
7710       double precision function eello4(i,j,k,l,jj,kk)
7711       implicit real*8 (a-h,o-z)
7712       include 'DIMENSIONS'
7713       include 'COMMON.IOUNITS'
7714       include 'COMMON.CHAIN'
7715       include 'COMMON.DERIV'
7716       include 'COMMON.INTERACT'
7717       include 'COMMON.CONTACTS'
7718       include 'COMMON.TORSION'
7719       include 'COMMON.VAR'
7720       include 'COMMON.GEO'
7721       double precision pizda(2,2),ggg1(3),ggg2(3)
7722 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7723 cd        eello4=0.0d0
7724 cd        return
7725 cd      endif
7726 cd      print *,'eello4:',i,j,k,l,jj,kk
7727 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7728 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7729 cold      eij=facont_hb(jj,i)
7730 cold      ekl=facont_hb(kk,k)
7731 cold      ekont=eij*ekl
7732       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7733 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7734       gcorr_loc(k-1)=gcorr_loc(k-1)
7735      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7736       if (l.eq.j+1) then
7737         gcorr_loc(l-1)=gcorr_loc(l-1)
7738      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7739       else
7740         gcorr_loc(j-1)=gcorr_loc(j-1)
7741      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7742       endif
7743       do iii=1,2
7744         do kkk=1,5
7745           do lll=1,3
7746             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7747      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7748 cd            derx(lll,kkk,iii)=0.0d0
7749           enddo
7750         enddo
7751       enddo
7752 cd      gcorr_loc(l-1)=0.0d0
7753 cd      gcorr_loc(j-1)=0.0d0
7754 cd      gcorr_loc(k-1)=0.0d0
7755 cd      eel4=1.0d0
7756 cd      write (iout,*)'Contacts have occurred for peptide groups',
7757 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7758 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7759       if (j.lt.nres-1) then
7760         j1=j+1
7761         j2=j-1
7762       else
7763         j1=j-1
7764         j2=j-2
7765       endif
7766       if (l.lt.nres-1) then
7767         l1=l+1
7768         l2=l-1
7769       else
7770         l1=l-1
7771         l2=l-2
7772       endif
7773       do ll=1,3
7774 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7775 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7776         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7777         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7778 cgrad        ghalf=0.5d0*ggg1(ll)
7779         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7780         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7781         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7782         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7783         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7784         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7785 cgrad        ghalf=0.5d0*ggg2(ll)
7786         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7787         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7788         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7789         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7790         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7791         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7792       enddo
7793 cgrad      do m=i+1,j-1
7794 cgrad        do ll=1,3
7795 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7796 cgrad        enddo
7797 cgrad      enddo
7798 cgrad      do m=k+1,l-1
7799 cgrad        do ll=1,3
7800 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7801 cgrad        enddo
7802 cgrad      enddo
7803 cgrad      do m=i+2,j2
7804 cgrad        do ll=1,3
7805 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7806 cgrad        enddo
7807 cgrad      enddo
7808 cgrad      do m=k+2,l2
7809 cgrad        do ll=1,3
7810 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7811 cgrad        enddo
7812 cgrad      enddo
7813 cd      do iii=1,nres-3
7814 cd        write (2,*) iii,gcorr_loc(iii)
7815 cd      enddo
7816       eello4=ekont*eel4
7817 cd      write (2,*) 'ekont',ekont
7818 cd      write (iout,*) 'eello4',ekont*eel4
7819       return
7820       end
7821 C---------------------------------------------------------------------------
7822       double precision function eello5(i,j,k,l,jj,kk)
7823       implicit real*8 (a-h,o-z)
7824       include 'DIMENSIONS'
7825       include 'COMMON.IOUNITS'
7826       include 'COMMON.CHAIN'
7827       include 'COMMON.DERIV'
7828       include 'COMMON.INTERACT'
7829       include 'COMMON.CONTACTS'
7830       include 'COMMON.TORSION'
7831       include 'COMMON.VAR'
7832       include 'COMMON.GEO'
7833       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7834       double precision ggg1(3),ggg2(3)
7835 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7836 C                                                                              C
7837 C                            Parallel chains                                   C
7838 C                                                                              C
7839 C          o             o                   o             o                   C
7840 C         /l\           / \             \   / \           / \   /              C
7841 C        /   \         /   \             \ /   \         /   \ /               C
7842 C       j| o |l1       | o |              o| o |         | o |o                C
7843 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7844 C      \i/   \         /   \ /             /   \         /   \                 C
7845 C       o    k1             o                                                  C
7846 C         (I)          (II)                (III)          (IV)                 C
7847 C                                                                              C
7848 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7849 C                                                                              C
7850 C                            Antiparallel chains                               C
7851 C                                                                              C
7852 C          o             o                   o             o                   C
7853 C         /j\           / \             \   / \           / \   /              C
7854 C        /   \         /   \             \ /   \         /   \ /               C
7855 C      j1| o |l        | o |              o| o |         | o |o                C
7856 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7857 C      \i/   \         /   \ /             /   \         /   \                 C
7858 C       o     k1            o                                                  C
7859 C         (I)          (II)                (III)          (IV)                 C
7860 C                                                                              C
7861 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7862 C                                                                              C
7863 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7864 C                                                                              C
7865 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7866 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7867 cd        eello5=0.0d0
7868 cd        return
7869 cd      endif
7870 cd      write (iout,*)
7871 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7872 cd     &   ' and',k,l
7873       itk=itortyp(itype(k))
7874       itl=itortyp(itype(l))
7875       itj=itortyp(itype(j))
7876       eello5_1=0.0d0
7877       eello5_2=0.0d0
7878       eello5_3=0.0d0
7879       eello5_4=0.0d0
7880 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7881 cd     &   eel5_3_num,eel5_4_num)
7882       do iii=1,2
7883         do kkk=1,5
7884           do lll=1,3
7885             derx(lll,kkk,iii)=0.0d0
7886           enddo
7887         enddo
7888       enddo
7889 cd      eij=facont_hb(jj,i)
7890 cd      ekl=facont_hb(kk,k)
7891 cd      ekont=eij*ekl
7892 cd      write (iout,*)'Contacts have occurred for peptide groups',
7893 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7894 cd      goto 1111
7895 C Contribution from the graph I.
7896 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7897 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7898       call transpose2(EUg(1,1,k),auxmat(1,1))
7899       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7900       vv(1)=pizda(1,1)-pizda(2,2)
7901       vv(2)=pizda(1,2)+pizda(2,1)
7902       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7903      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7904 C Explicit gradient in virtual-dihedral angles.
7905       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7906      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7907      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7908       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7909       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7910       vv(1)=pizda(1,1)-pizda(2,2)
7911       vv(2)=pizda(1,2)+pizda(2,1)
7912       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7913      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7914      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7915       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7916       vv(1)=pizda(1,1)-pizda(2,2)
7917       vv(2)=pizda(1,2)+pizda(2,1)
7918       if (l.eq.j+1) then
7919         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7920      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7921      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7922       else
7923         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7924      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7925      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7926       endif
7927 C Cartesian gradient
7928       do iii=1,2
7929         do kkk=1,5
7930           do lll=1,3
7931             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7932      &        pizda(1,1))
7933             vv(1)=pizda(1,1)-pizda(2,2)
7934             vv(2)=pizda(1,2)+pizda(2,1)
7935             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7936      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7937      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7938           enddo
7939         enddo
7940       enddo
7941 c      goto 1112
7942 c1111  continue
7943 C Contribution from graph II
7944       call transpose2(EE(1,1,itk),auxmat(1,1))
7945       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7946       vv(1)=pizda(1,1)+pizda(2,2)
7947       vv(2)=pizda(2,1)-pizda(1,2)
7948       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7949      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7950 C Explicit gradient in virtual-dihedral angles.
7951       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7952      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7953       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7954       vv(1)=pizda(1,1)+pizda(2,2)
7955       vv(2)=pizda(2,1)-pizda(1,2)
7956       if (l.eq.j+1) then
7957         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7958      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7959      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7960       else
7961         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7962      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7963      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7964       endif
7965 C Cartesian gradient
7966       do iii=1,2
7967         do kkk=1,5
7968           do lll=1,3
7969             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7970      &        pizda(1,1))
7971             vv(1)=pizda(1,1)+pizda(2,2)
7972             vv(2)=pizda(2,1)-pizda(1,2)
7973             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7974      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7975      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7976           enddo
7977         enddo
7978       enddo
7979 cd      goto 1112
7980 cd1111  continue
7981       if (l.eq.j+1) then
7982 cd        goto 1110
7983 C Parallel orientation
7984 C Contribution from graph III
7985         call transpose2(EUg(1,1,l),auxmat(1,1))
7986         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7987         vv(1)=pizda(1,1)-pizda(2,2)
7988         vv(2)=pizda(1,2)+pizda(2,1)
7989         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7990      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7991 C Explicit gradient in virtual-dihedral angles.
7992         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7993      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7994      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7995         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7996         vv(1)=pizda(1,1)-pizda(2,2)
7997         vv(2)=pizda(1,2)+pizda(2,1)
7998         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7999      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8000      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8001         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8002         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8003         vv(1)=pizda(1,1)-pizda(2,2)
8004         vv(2)=pizda(1,2)+pizda(2,1)
8005         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8006      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8007      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8008 C Cartesian gradient
8009         do iii=1,2
8010           do kkk=1,5
8011             do lll=1,3
8012               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8013      &          pizda(1,1))
8014               vv(1)=pizda(1,1)-pizda(2,2)
8015               vv(2)=pizda(1,2)+pizda(2,1)
8016               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8017      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8018      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8019             enddo
8020           enddo
8021         enddo
8022 cd        goto 1112
8023 C Contribution from graph IV
8024 cd1110    continue
8025         call transpose2(EE(1,1,itl),auxmat(1,1))
8026         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8027         vv(1)=pizda(1,1)+pizda(2,2)
8028         vv(2)=pizda(2,1)-pizda(1,2)
8029         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8030      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8031 C Explicit gradient in virtual-dihedral angles.
8032         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8033      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8034         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8035         vv(1)=pizda(1,1)+pizda(2,2)
8036         vv(2)=pizda(2,1)-pizda(1,2)
8037         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8038      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8039      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8040 C Cartesian gradient
8041         do iii=1,2
8042           do kkk=1,5
8043             do lll=1,3
8044               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8045      &          pizda(1,1))
8046               vv(1)=pizda(1,1)+pizda(2,2)
8047               vv(2)=pizda(2,1)-pizda(1,2)
8048               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8049      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8050      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8051             enddo
8052           enddo
8053         enddo
8054       else
8055 C Antiparallel orientation
8056 C Contribution from graph III
8057 c        goto 1110
8058         call transpose2(EUg(1,1,j),auxmat(1,1))
8059         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8060         vv(1)=pizda(1,1)-pizda(2,2)
8061         vv(2)=pizda(1,2)+pizda(2,1)
8062         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8063      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8064 C Explicit gradient in virtual-dihedral angles.
8065         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8066      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8067      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8068         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8069         vv(1)=pizda(1,1)-pizda(2,2)
8070         vv(2)=pizda(1,2)+pizda(2,1)
8071         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8072      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8073      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8074         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8075         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8076         vv(1)=pizda(1,1)-pizda(2,2)
8077         vv(2)=pizda(1,2)+pizda(2,1)
8078         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8079      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8080      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8081 C Cartesian gradient
8082         do iii=1,2
8083           do kkk=1,5
8084             do lll=1,3
8085               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8086      &          pizda(1,1))
8087               vv(1)=pizda(1,1)-pizda(2,2)
8088               vv(2)=pizda(1,2)+pizda(2,1)
8089               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8090      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8091      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8092             enddo
8093           enddo
8094         enddo
8095 cd        goto 1112
8096 C Contribution from graph IV
8097 1110    continue
8098         call transpose2(EE(1,1,itj),auxmat(1,1))
8099         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8100         vv(1)=pizda(1,1)+pizda(2,2)
8101         vv(2)=pizda(2,1)-pizda(1,2)
8102         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8103      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8104 C Explicit gradient in virtual-dihedral angles.
8105         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8106      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8107         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8108         vv(1)=pizda(1,1)+pizda(2,2)
8109         vv(2)=pizda(2,1)-pizda(1,2)
8110         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8111      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8112      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8113 C Cartesian gradient
8114         do iii=1,2
8115           do kkk=1,5
8116             do lll=1,3
8117               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8118      &          pizda(1,1))
8119               vv(1)=pizda(1,1)+pizda(2,2)
8120               vv(2)=pizda(2,1)-pizda(1,2)
8121               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8122      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8123      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8124             enddo
8125           enddo
8126         enddo
8127       endif
8128 1112  continue
8129       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8130 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8131 cd        write (2,*) 'ijkl',i,j,k,l
8132 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8133 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8134 cd      endif
8135 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8136 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8137 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8138 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8139       if (j.lt.nres-1) then
8140         j1=j+1
8141         j2=j-1
8142       else
8143         j1=j-1
8144         j2=j-2
8145       endif
8146       if (l.lt.nres-1) then
8147         l1=l+1
8148         l2=l-1
8149       else
8150         l1=l-1
8151         l2=l-2
8152       endif
8153 cd      eij=1.0d0
8154 cd      ekl=1.0d0
8155 cd      ekont=1.0d0
8156 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8157 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8158 C        summed up outside the subrouine as for the other subroutines
8159 C        handling long-range interactions. The old code is commented out
8160 C        with "cgrad" to keep track of changes.
8161       do ll=1,3
8162 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8163 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8164         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8165         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8166 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8167 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8168 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8169 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8170 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8171 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8172 c     &   gradcorr5ij,
8173 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8174 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8175 cgrad        ghalf=0.5d0*ggg1(ll)
8176 cd        ghalf=0.0d0
8177         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8178         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8179         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8180         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8181         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8182         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8183 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8184 cgrad        ghalf=0.5d0*ggg2(ll)
8185 cd        ghalf=0.0d0
8186         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8187         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8188         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8189         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8190         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8191         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8192       enddo
8193 cd      goto 1112
8194 cgrad      do m=i+1,j-1
8195 cgrad        do ll=1,3
8196 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8197 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8198 cgrad        enddo
8199 cgrad      enddo
8200 cgrad      do m=k+1,l-1
8201 cgrad        do ll=1,3
8202 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8203 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8204 cgrad        enddo
8205 cgrad      enddo
8206 c1112  continue
8207 cgrad      do m=i+2,j2
8208 cgrad        do ll=1,3
8209 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8210 cgrad        enddo
8211 cgrad      enddo
8212 cgrad      do m=k+2,l2
8213 cgrad        do ll=1,3
8214 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8215 cgrad        enddo
8216 cgrad      enddo
8217 cd      do iii=1,nres-3
8218 cd        write (2,*) iii,g_corr5_loc(iii)
8219 cd      enddo
8220       eello5=ekont*eel5
8221 cd      write (2,*) 'ekont',ekont
8222 cd      write (iout,*) 'eello5',ekont*eel5
8223       return
8224       end
8225 c--------------------------------------------------------------------------
8226       double precision function eello6(i,j,k,l,jj,kk)
8227       implicit real*8 (a-h,o-z)
8228       include 'DIMENSIONS'
8229       include 'COMMON.IOUNITS'
8230       include 'COMMON.CHAIN'
8231       include 'COMMON.DERIV'
8232       include 'COMMON.INTERACT'
8233       include 'COMMON.CONTACTS'
8234       include 'COMMON.TORSION'
8235       include 'COMMON.VAR'
8236       include 'COMMON.GEO'
8237       include 'COMMON.FFIELD'
8238       double precision ggg1(3),ggg2(3)
8239 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8240 cd        eello6=0.0d0
8241 cd        return
8242 cd      endif
8243 cd      write (iout,*)
8244 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8245 cd     &   ' and',k,l
8246       eello6_1=0.0d0
8247       eello6_2=0.0d0
8248       eello6_3=0.0d0
8249       eello6_4=0.0d0
8250       eello6_5=0.0d0
8251       eello6_6=0.0d0
8252 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8253 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8254       do iii=1,2
8255         do kkk=1,5
8256           do lll=1,3
8257             derx(lll,kkk,iii)=0.0d0
8258           enddo
8259         enddo
8260       enddo
8261 cd      eij=facont_hb(jj,i)
8262 cd      ekl=facont_hb(kk,k)
8263 cd      ekont=eij*ekl
8264 cd      eij=1.0d0
8265 cd      ekl=1.0d0
8266 cd      ekont=1.0d0
8267       if (l.eq.j+1) then
8268         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8269         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8270         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8271         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8272         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8273         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8274       else
8275         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8276         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8277         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8278         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8279         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8280           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8281         else
8282           eello6_5=0.0d0
8283         endif
8284         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8285       endif
8286 C If turn contributions are considered, they will be handled separately.
8287       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8288 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8289 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8290 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8291 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8292 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8293 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8294 cd      goto 1112
8295       if (j.lt.nres-1) then
8296         j1=j+1
8297         j2=j-1
8298       else
8299         j1=j-1
8300         j2=j-2
8301       endif
8302       if (l.lt.nres-1) then
8303         l1=l+1
8304         l2=l-1
8305       else
8306         l1=l-1
8307         l2=l-2
8308       endif
8309       do ll=1,3
8310 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8311 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8312 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8313 cgrad        ghalf=0.5d0*ggg1(ll)
8314 cd        ghalf=0.0d0
8315         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8316         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8317         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8318         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8319         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8320         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8321         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8322         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8323 cgrad        ghalf=0.5d0*ggg2(ll)
8324 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8325 cd        ghalf=0.0d0
8326         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8327         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8328         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8329         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8330         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8331         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8332       enddo
8333 cd      goto 1112
8334 cgrad      do m=i+1,j-1
8335 cgrad        do ll=1,3
8336 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8337 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8338 cgrad        enddo
8339 cgrad      enddo
8340 cgrad      do m=k+1,l-1
8341 cgrad        do ll=1,3
8342 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8343 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8344 cgrad        enddo
8345 cgrad      enddo
8346 cgrad1112  continue
8347 cgrad      do m=i+2,j2
8348 cgrad        do ll=1,3
8349 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8350 cgrad        enddo
8351 cgrad      enddo
8352 cgrad      do m=k+2,l2
8353 cgrad        do ll=1,3
8354 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8355 cgrad        enddo
8356 cgrad      enddo
8357 cd      do iii=1,nres-3
8358 cd        write (2,*) iii,g_corr6_loc(iii)
8359 cd      enddo
8360       eello6=ekont*eel6
8361 cd      write (2,*) 'ekont',ekont
8362 cd      write (iout,*) 'eello6',ekont*eel6
8363       return
8364       end
8365 c--------------------------------------------------------------------------
8366       double precision function eello6_graph1(i,j,k,l,imat,swap)
8367       implicit real*8 (a-h,o-z)
8368       include 'DIMENSIONS'
8369       include 'COMMON.IOUNITS'
8370       include 'COMMON.CHAIN'
8371       include 'COMMON.DERIV'
8372       include 'COMMON.INTERACT'
8373       include 'COMMON.CONTACTS'
8374       include 'COMMON.TORSION'
8375       include 'COMMON.VAR'
8376       include 'COMMON.GEO'
8377       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8378       logical swap
8379       logical lprn
8380       common /kutas/ lprn
8381 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8382 C
8383 C      Parallel       Antiparallel
8384 C
8385 C          o             o
8386 C         /l\           /j\
8387 C        /   \         /   \
8388 C       /| o |         | o |\
8389 C     \ j|/k\|  /   \  |/k\|l /
8390 C      \ /   \ /     \ /   \ /
8391 C       o     o       o     o
8392 C       i             i
8393 C
8394 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8395       itk=itortyp(itype(k))
8396       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8397       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8398       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8399       call transpose2(EUgC(1,1,k),auxmat(1,1))
8400       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8401       vv1(1)=pizda1(1,1)-pizda1(2,2)
8402       vv1(2)=pizda1(1,2)+pizda1(2,1)
8403       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8404       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8405       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8406       s5=scalar2(vv(1),Dtobr2(1,i))
8407 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8408       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8409       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8410      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8411      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8412      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8413      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8414      & +scalar2(vv(1),Dtobr2der(1,i)))
8415       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8416       vv1(1)=pizda1(1,1)-pizda1(2,2)
8417       vv1(2)=pizda1(1,2)+pizda1(2,1)
8418       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8419       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8420       if (l.eq.j+1) then
8421         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8422      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8423      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8424      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8425      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8426       else
8427         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8428      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8429      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8430      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8431      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8432       endif
8433       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8434       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8435       vv1(1)=pizda1(1,1)-pizda1(2,2)
8436       vv1(2)=pizda1(1,2)+pizda1(2,1)
8437       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8438      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8439      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8440      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8441       do iii=1,2
8442         if (swap) then
8443           ind=3-iii
8444         else
8445           ind=iii
8446         endif
8447         do kkk=1,5
8448           do lll=1,3
8449             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8450             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8451             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8452             call transpose2(EUgC(1,1,k),auxmat(1,1))
8453             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8454      &        pizda1(1,1))
8455             vv1(1)=pizda1(1,1)-pizda1(2,2)
8456             vv1(2)=pizda1(1,2)+pizda1(2,1)
8457             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8458             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8459      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8460             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8461      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8462             s5=scalar2(vv(1),Dtobr2(1,i))
8463             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8464           enddo
8465         enddo
8466       enddo
8467       return
8468       end
8469 c----------------------------------------------------------------------------
8470       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8471       implicit real*8 (a-h,o-z)
8472       include 'DIMENSIONS'
8473       include 'COMMON.IOUNITS'
8474       include 'COMMON.CHAIN'
8475       include 'COMMON.DERIV'
8476       include 'COMMON.INTERACT'
8477       include 'COMMON.CONTACTS'
8478       include 'COMMON.TORSION'
8479       include 'COMMON.VAR'
8480       include 'COMMON.GEO'
8481       logical swap
8482       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8483      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8484       logical lprn
8485       common /kutas/ lprn
8486 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8487 C                                                                              C
8488 C      Parallel       Antiparallel                                             C
8489 C                                                                              C
8490 C          o             o                                                     C
8491 C     \   /l\           /j\   /                                                C
8492 C      \ /   \         /   \ /                                                 C
8493 C       o| o |         | o |o                                                  C
8494 C     \ j|/k\|      \  |/k\|l                                                  C
8495 C      \ /   \       \ /   \                                                   C
8496 C       o             o                                                        C
8497 C       i             i                                                        C
8498 C                                                                              C
8499 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8500 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8501 C AL 7/4/01 s1 would occur in the sixth-order moment,
8502 C           but not in a cluster cumulant
8503 #ifdef MOMENT
8504       s1=dip(1,jj,i)*dip(1,kk,k)
8505 #endif
8506       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8507       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8508       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8509       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8510       call transpose2(EUg(1,1,k),auxmat(1,1))
8511       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8512       vv(1)=pizda(1,1)-pizda(2,2)
8513       vv(2)=pizda(1,2)+pizda(2,1)
8514       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8515 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8516 #ifdef MOMENT
8517       eello6_graph2=-(s1+s2+s3+s4)
8518 #else
8519       eello6_graph2=-(s2+s3+s4)
8520 #endif
8521 c      eello6_graph2=-s3
8522 C Derivatives in gamma(i-1)
8523       if (i.gt.1) then
8524 #ifdef MOMENT
8525         s1=dipderg(1,jj,i)*dip(1,kk,k)
8526 #endif
8527         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8528         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8529         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8530         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8531 #ifdef MOMENT
8532         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8533 #else
8534         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8535 #endif
8536 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8537       endif
8538 C Derivatives in gamma(k-1)
8539 #ifdef MOMENT
8540       s1=dip(1,jj,i)*dipderg(1,kk,k)
8541 #endif
8542       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8543       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8544       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8545       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8546       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8547       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8548       vv(1)=pizda(1,1)-pizda(2,2)
8549       vv(2)=pizda(1,2)+pizda(2,1)
8550       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8551 #ifdef MOMENT
8552       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8553 #else
8554       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8555 #endif
8556 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8557 C Derivatives in gamma(j-1) or gamma(l-1)
8558       if (j.gt.1) then
8559 #ifdef MOMENT
8560         s1=dipderg(3,jj,i)*dip(1,kk,k)
8561 #endif
8562         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8563         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8564         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8565         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8566         vv(1)=pizda(1,1)-pizda(2,2)
8567         vv(2)=pizda(1,2)+pizda(2,1)
8568         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8569 #ifdef MOMENT
8570         if (swap) then
8571           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8572         else
8573           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8574         endif
8575 #endif
8576         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8577 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8578       endif
8579 C Derivatives in gamma(l-1) or gamma(j-1)
8580       if (l.gt.1) then
8581 #ifdef MOMENT
8582         s1=dip(1,jj,i)*dipderg(3,kk,k)
8583 #endif
8584         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8585         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8586         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8587         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8588         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8589         vv(1)=pizda(1,1)-pizda(2,2)
8590         vv(2)=pizda(1,2)+pizda(2,1)
8591         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8592 #ifdef MOMENT
8593         if (swap) then
8594           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8595         else
8596           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8597         endif
8598 #endif
8599         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8600 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8601       endif
8602 C Cartesian derivatives.
8603       if (lprn) then
8604         write (2,*) 'In eello6_graph2'
8605         do iii=1,2
8606           write (2,*) 'iii=',iii
8607           do kkk=1,5
8608             write (2,*) 'kkk=',kkk
8609             do jjj=1,2
8610               write (2,'(3(2f10.5),5x)')
8611      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8612             enddo
8613           enddo
8614         enddo
8615       endif
8616       do iii=1,2
8617         do kkk=1,5
8618           do lll=1,3
8619 #ifdef MOMENT
8620             if (iii.eq.1) then
8621               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8622             else
8623               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8624             endif
8625 #endif
8626             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8627      &        auxvec(1))
8628             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8629             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8630      &        auxvec(1))
8631             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8632             call transpose2(EUg(1,1,k),auxmat(1,1))
8633             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8634      &        pizda(1,1))
8635             vv(1)=pizda(1,1)-pizda(2,2)
8636             vv(2)=pizda(1,2)+pizda(2,1)
8637             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8638 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8639 #ifdef MOMENT
8640             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8641 #else
8642             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8643 #endif
8644             if (swap) then
8645               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8646             else
8647               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8648             endif
8649           enddo
8650         enddo
8651       enddo
8652       return
8653       end
8654 c----------------------------------------------------------------------------
8655       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8656       implicit real*8 (a-h,o-z)
8657       include 'DIMENSIONS'
8658       include 'COMMON.IOUNITS'
8659       include 'COMMON.CHAIN'
8660       include 'COMMON.DERIV'
8661       include 'COMMON.INTERACT'
8662       include 'COMMON.CONTACTS'
8663       include 'COMMON.TORSION'
8664       include 'COMMON.VAR'
8665       include 'COMMON.GEO'
8666       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8667       logical swap
8668 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8669 C                                                                              C
8670 C      Parallel       Antiparallel                                             C
8671 C                                                                              C
8672 C          o             o                                                     C
8673 C         /l\   /   \   /j\                                                    C
8674 C        /   \ /     \ /   \                                                   C
8675 C       /| o |o       o| o |\                                                  C
8676 C       j|/k\|  /      |/k\|l /                                                C
8677 C        /   \ /       /   \ /                                                 C
8678 C       /     o       /     o                                                  C
8679 C       i             i                                                        C
8680 C                                                                              C
8681 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8682 C
8683 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8684 C           energy moment and not to the cluster cumulant.
8685       iti=itortyp(itype(i))
8686       if (j.lt.nres-1) then
8687         itj1=itortyp(itype(j+1))
8688       else
8689         itj1=ntortyp+1
8690       endif
8691       itk=itortyp(itype(k))
8692       itk1=itortyp(itype(k+1))
8693       if (l.lt.nres-1) then
8694         itl1=itortyp(itype(l+1))
8695       else
8696         itl1=ntortyp+1
8697       endif
8698 #ifdef MOMENT
8699       s1=dip(4,jj,i)*dip(4,kk,k)
8700 #endif
8701       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8702       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8703       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8704       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8705       call transpose2(EE(1,1,itk),auxmat(1,1))
8706       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8707       vv(1)=pizda(1,1)+pizda(2,2)
8708       vv(2)=pizda(2,1)-pizda(1,2)
8709       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8710 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8711 cd     & "sum",-(s2+s3+s4)
8712 #ifdef MOMENT
8713       eello6_graph3=-(s1+s2+s3+s4)
8714 #else
8715       eello6_graph3=-(s2+s3+s4)
8716 #endif
8717 c      eello6_graph3=-s4
8718 C Derivatives in gamma(k-1)
8719       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8720       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8721       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8722       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8723 C Derivatives in gamma(l-1)
8724       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8725       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8726       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8727       vv(1)=pizda(1,1)+pizda(2,2)
8728       vv(2)=pizda(2,1)-pizda(1,2)
8729       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8730       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8731 C Cartesian derivatives.
8732       do iii=1,2
8733         do kkk=1,5
8734           do lll=1,3
8735 #ifdef MOMENT
8736             if (iii.eq.1) then
8737               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8738             else
8739               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8740             endif
8741 #endif
8742             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8743      &        auxvec(1))
8744             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8745             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8746      &        auxvec(1))
8747             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8748             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8749      &        pizda(1,1))
8750             vv(1)=pizda(1,1)+pizda(2,2)
8751             vv(2)=pizda(2,1)-pizda(1,2)
8752             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8753 #ifdef MOMENT
8754             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8755 #else
8756             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8757 #endif
8758             if (swap) then
8759               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8760             else
8761               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8762             endif
8763 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8764           enddo
8765         enddo
8766       enddo
8767       return
8768       end
8769 c----------------------------------------------------------------------------
8770       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8771       implicit real*8 (a-h,o-z)
8772       include 'DIMENSIONS'
8773       include 'COMMON.IOUNITS'
8774       include 'COMMON.CHAIN'
8775       include 'COMMON.DERIV'
8776       include 'COMMON.INTERACT'
8777       include 'COMMON.CONTACTS'
8778       include 'COMMON.TORSION'
8779       include 'COMMON.VAR'
8780       include 'COMMON.GEO'
8781       include 'COMMON.FFIELD'
8782       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8783      & auxvec1(2),auxmat1(2,2)
8784       logical swap
8785 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8786 C                                                                              C
8787 C      Parallel       Antiparallel                                             C
8788 C                                                                              C
8789 C          o             o                                                     C
8790 C         /l\   /   \   /j\                                                    C
8791 C        /   \ /     \ /   \                                                   C
8792 C       /| o |o       o| o |\                                                  C
8793 C     \ j|/k\|      \  |/k\|l                                                  C
8794 C      \ /   \       \ /   \                                                   C
8795 C       o     \       o     \                                                  C
8796 C       i             i                                                        C
8797 C                                                                              C
8798 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8799 C
8800 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8801 C           energy moment and not to the cluster cumulant.
8802 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8803       iti=itortyp(itype(i))
8804       itj=itortyp(itype(j))
8805       if (j.lt.nres-1) then
8806         itj1=itortyp(itype(j+1))
8807       else
8808         itj1=ntortyp+1
8809       endif
8810       itk=itortyp(itype(k))
8811       if (k.lt.nres-1) then
8812         itk1=itortyp(itype(k+1))
8813       else
8814         itk1=ntortyp+1
8815       endif
8816       itl=itortyp(itype(l))
8817       if (l.lt.nres-1) then
8818         itl1=itortyp(itype(l+1))
8819       else
8820         itl1=ntortyp+1
8821       endif
8822 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8823 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8824 cd     & ' itl',itl,' itl1',itl1
8825 #ifdef MOMENT
8826       if (imat.eq.1) then
8827         s1=dip(3,jj,i)*dip(3,kk,k)
8828       else
8829         s1=dip(2,jj,j)*dip(2,kk,l)
8830       endif
8831 #endif
8832       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8833       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8834       if (j.eq.l+1) then
8835         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8836         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8837       else
8838         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8839         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8840       endif
8841       call transpose2(EUg(1,1,k),auxmat(1,1))
8842       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8843       vv(1)=pizda(1,1)-pizda(2,2)
8844       vv(2)=pizda(2,1)+pizda(1,2)
8845       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8846 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8847 #ifdef MOMENT
8848       eello6_graph4=-(s1+s2+s3+s4)
8849 #else
8850       eello6_graph4=-(s2+s3+s4)
8851 #endif
8852 C Derivatives in gamma(i-1)
8853       if (i.gt.1) then
8854 #ifdef MOMENT
8855         if (imat.eq.1) then
8856           s1=dipderg(2,jj,i)*dip(3,kk,k)
8857         else
8858           s1=dipderg(4,jj,j)*dip(2,kk,l)
8859         endif
8860 #endif
8861         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8862         if (j.eq.l+1) then
8863           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8864           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8865         else
8866           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8867           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8868         endif
8869         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8870         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8871 cd          write (2,*) 'turn6 derivatives'
8872 #ifdef MOMENT
8873           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8874 #else
8875           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8876 #endif
8877         else
8878 #ifdef MOMENT
8879           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8880 #else
8881           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8882 #endif
8883         endif
8884       endif
8885 C Derivatives in gamma(k-1)
8886 #ifdef MOMENT
8887       if (imat.eq.1) then
8888         s1=dip(3,jj,i)*dipderg(2,kk,k)
8889       else
8890         s1=dip(2,jj,j)*dipderg(4,kk,l)
8891       endif
8892 #endif
8893       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8894       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8895       if (j.eq.l+1) then
8896         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8897         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8898       else
8899         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8900         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8901       endif
8902       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8903       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8904       vv(1)=pizda(1,1)-pizda(2,2)
8905       vv(2)=pizda(2,1)+pizda(1,2)
8906       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8907       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8908 #ifdef MOMENT
8909         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8910 #else
8911         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8912 #endif
8913       else
8914 #ifdef MOMENT
8915         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8916 #else
8917         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8918 #endif
8919       endif
8920 C Derivatives in gamma(j-1) or gamma(l-1)
8921       if (l.eq.j+1 .and. l.gt.1) then
8922         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8923         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8924         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8925         vv(1)=pizda(1,1)-pizda(2,2)
8926         vv(2)=pizda(2,1)+pizda(1,2)
8927         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8928         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8929       else if (j.gt.1) then
8930         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8931         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8932         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8933         vv(1)=pizda(1,1)-pizda(2,2)
8934         vv(2)=pizda(2,1)+pizda(1,2)
8935         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8936         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8937           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8938         else
8939           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8940         endif
8941       endif
8942 C Cartesian derivatives.
8943       do iii=1,2
8944         do kkk=1,5
8945           do lll=1,3
8946 #ifdef MOMENT
8947             if (iii.eq.1) then
8948               if (imat.eq.1) then
8949                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8950               else
8951                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8952               endif
8953             else
8954               if (imat.eq.1) then
8955                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8956               else
8957                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8958               endif
8959             endif
8960 #endif
8961             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8962      &        auxvec(1))
8963             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8964             if (j.eq.l+1) then
8965               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8966      &          b1(1,itj1),auxvec(1))
8967               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8968             else
8969               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8970      &          b1(1,itl1),auxvec(1))
8971               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8972             endif
8973             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8974      &        pizda(1,1))
8975             vv(1)=pizda(1,1)-pizda(2,2)
8976             vv(2)=pizda(2,1)+pizda(1,2)
8977             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8978             if (swap) then
8979               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8980 #ifdef MOMENT
8981                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8982      &             -(s1+s2+s4)
8983 #else
8984                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8985      &             -(s2+s4)
8986 #endif
8987                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8988               else
8989 #ifdef MOMENT
8990                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8991 #else
8992                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8993 #endif
8994                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8995               endif
8996             else
8997 #ifdef MOMENT
8998               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8999 #else
9000               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9001 #endif
9002               if (l.eq.j+1) then
9003                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9004               else
9005                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9006               endif
9007             endif
9008           enddo
9009         enddo
9010       enddo
9011       return
9012       end
9013 c----------------------------------------------------------------------------
9014       double precision function eello_turn6(i,jj,kk)
9015       implicit real*8 (a-h,o-z)
9016       include 'DIMENSIONS'
9017       include 'COMMON.IOUNITS'
9018       include 'COMMON.CHAIN'
9019       include 'COMMON.DERIV'
9020       include 'COMMON.INTERACT'
9021       include 'COMMON.CONTACTS'
9022       include 'COMMON.TORSION'
9023       include 'COMMON.VAR'
9024       include 'COMMON.GEO'
9025       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9026      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9027      &  ggg1(3),ggg2(3)
9028       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9029      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9030 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9031 C           the respective energy moment and not to the cluster cumulant.
9032       s1=0.0d0
9033       s8=0.0d0
9034       s13=0.0d0
9035 c
9036       eello_turn6=0.0d0
9037       j=i+4
9038       k=i+1
9039       l=i+3
9040       iti=itortyp(itype(i))
9041       itk=itortyp(itype(k))
9042       itk1=itortyp(itype(k+1))
9043       itl=itortyp(itype(l))
9044       itj=itortyp(itype(j))
9045 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9046 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9047 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9048 cd        eello6=0.0d0
9049 cd        return
9050 cd      endif
9051 cd      write (iout,*)
9052 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9053 cd     &   ' and',k,l
9054 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9055       do iii=1,2
9056         do kkk=1,5
9057           do lll=1,3
9058             derx_turn(lll,kkk,iii)=0.0d0
9059           enddo
9060         enddo
9061       enddo
9062 cd      eij=1.0d0
9063 cd      ekl=1.0d0
9064 cd      ekont=1.0d0
9065       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9066 cd      eello6_5=0.0d0
9067 cd      write (2,*) 'eello6_5',eello6_5
9068 #ifdef MOMENT
9069       call transpose2(AEA(1,1,1),auxmat(1,1))
9070       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9071       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9072       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9073 #endif
9074       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9075       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9076       s2 = scalar2(b1(1,itk),vtemp1(1))
9077 #ifdef MOMENT
9078       call transpose2(AEA(1,1,2),atemp(1,1))
9079       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9080       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9081       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9082 #endif
9083       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9084       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9085       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9086 #ifdef MOMENT
9087       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9088       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9089       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9090       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9091       ss13 = scalar2(b1(1,itk),vtemp4(1))
9092       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9093 #endif
9094 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9095 c      s1=0.0d0
9096 c      s2=0.0d0
9097 c      s8=0.0d0
9098 c      s12=0.0d0
9099 c      s13=0.0d0
9100       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9101 C Derivatives in gamma(i+2)
9102       s1d =0.0d0
9103       s8d =0.0d0
9104 #ifdef MOMENT
9105       call transpose2(AEA(1,1,1),auxmatd(1,1))
9106       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9107       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9108       call transpose2(AEAderg(1,1,2),atempd(1,1))
9109       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9110       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9111 #endif
9112       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9113       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9114       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9115 c      s1d=0.0d0
9116 c      s2d=0.0d0
9117 c      s8d=0.0d0
9118 c      s12d=0.0d0
9119 c      s13d=0.0d0
9120       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9121 C Derivatives in gamma(i+3)
9122 #ifdef MOMENT
9123       call transpose2(AEA(1,1,1),auxmatd(1,1))
9124       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9125       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9126       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9127 #endif
9128       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9129       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9130       s2d = scalar2(b1(1,itk),vtemp1d(1))
9131 #ifdef MOMENT
9132       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9133       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9134 #endif
9135       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9136 #ifdef MOMENT
9137       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9138       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9139       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9140 #endif
9141 c      s1d=0.0d0
9142 c      s2d=0.0d0
9143 c      s8d=0.0d0
9144 c      s12d=0.0d0
9145 c      s13d=0.0d0
9146 #ifdef MOMENT
9147       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9148      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9149 #else
9150       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9151      &               -0.5d0*ekont*(s2d+s12d)
9152 #endif
9153 C Derivatives in gamma(i+4)
9154       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9155       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9156       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9157 #ifdef MOMENT
9158       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9159       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9160       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9161 #endif
9162 c      s1d=0.0d0
9163 c      s2d=0.0d0
9164 c      s8d=0.0d0
9165 C      s12d=0.0d0
9166 c      s13d=0.0d0
9167 #ifdef MOMENT
9168       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9169 #else
9170       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9171 #endif
9172 C Derivatives in gamma(i+5)
9173 #ifdef MOMENT
9174       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9175       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9176       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9177 #endif
9178       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9179       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9180       s2d = scalar2(b1(1,itk),vtemp1d(1))
9181 #ifdef MOMENT
9182       call transpose2(AEA(1,1,2),atempd(1,1))
9183       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9184       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9185 #endif
9186       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9187       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9188 #ifdef MOMENT
9189       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9190       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9191       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9192 #endif
9193 c      s1d=0.0d0
9194 c      s2d=0.0d0
9195 c      s8d=0.0d0
9196 c      s12d=0.0d0
9197 c      s13d=0.0d0
9198 #ifdef MOMENT
9199       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9200      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9201 #else
9202       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9203      &               -0.5d0*ekont*(s2d+s12d)
9204 #endif
9205 C Cartesian derivatives
9206       do iii=1,2
9207         do kkk=1,5
9208           do lll=1,3
9209 #ifdef MOMENT
9210             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9211             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9212             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9213 #endif
9214             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9215             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9216      &          vtemp1d(1))
9217             s2d = scalar2(b1(1,itk),vtemp1d(1))
9218 #ifdef MOMENT
9219             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9220             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9221             s8d = -(atempd(1,1)+atempd(2,2))*
9222      &           scalar2(cc(1,1,itl),vtemp2(1))
9223 #endif
9224             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9225      &           auxmatd(1,1))
9226             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9227             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9228 c      s1d=0.0d0
9229 c      s2d=0.0d0
9230 c      s8d=0.0d0
9231 c      s12d=0.0d0
9232 c      s13d=0.0d0
9233 #ifdef MOMENT
9234             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9235      &        - 0.5d0*(s1d+s2d)
9236 #else
9237             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9238      &        - 0.5d0*s2d
9239 #endif
9240 #ifdef MOMENT
9241             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9242      &        - 0.5d0*(s8d+s12d)
9243 #else
9244             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9245      &        - 0.5d0*s12d
9246 #endif
9247           enddo
9248         enddo
9249       enddo
9250 #ifdef MOMENT
9251       do kkk=1,5
9252         do lll=1,3
9253           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9254      &      achuj_tempd(1,1))
9255           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9256           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9257           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9258           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9259           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9260      &      vtemp4d(1))
9261           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9262           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9263           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9264         enddo
9265       enddo
9266 #endif
9267 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9268 cd     &  16*eel_turn6_num
9269 cd      goto 1112
9270       if (j.lt.nres-1) then
9271         j1=j+1
9272         j2=j-1
9273       else
9274         j1=j-1
9275         j2=j-2
9276       endif
9277       if (l.lt.nres-1) then
9278         l1=l+1
9279         l2=l-1
9280       else
9281         l1=l-1
9282         l2=l-2
9283       endif
9284       do ll=1,3
9285 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9286 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9287 cgrad        ghalf=0.5d0*ggg1(ll)
9288 cd        ghalf=0.0d0
9289         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9290         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9291         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9292      &    +ekont*derx_turn(ll,2,1)
9293         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9294         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9295      &    +ekont*derx_turn(ll,4,1)
9296         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9297         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9298         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9299 cgrad        ghalf=0.5d0*ggg2(ll)
9300 cd        ghalf=0.0d0
9301         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9302      &    +ekont*derx_turn(ll,2,2)
9303         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9304         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9305      &    +ekont*derx_turn(ll,4,2)
9306         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9307         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9308         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9309       enddo
9310 cd      goto 1112
9311 cgrad      do m=i+1,j-1
9312 cgrad        do ll=1,3
9313 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9314 cgrad        enddo
9315 cgrad      enddo
9316 cgrad      do m=k+1,l-1
9317 cgrad        do ll=1,3
9318 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9319 cgrad        enddo
9320 cgrad      enddo
9321 cgrad1112  continue
9322 cgrad      do m=i+2,j2
9323 cgrad        do ll=1,3
9324 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9325 cgrad        enddo
9326 cgrad      enddo
9327 cgrad      do m=k+2,l2
9328 cgrad        do ll=1,3
9329 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9330 cgrad        enddo
9331 cgrad      enddo
9332 cd      do iii=1,nres-3
9333 cd        write (2,*) iii,g_corr6_loc(iii)
9334 cd      enddo
9335       eello_turn6=ekont*eel_turn6
9336 cd      write (2,*) 'ekont',ekont
9337 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9338       return
9339       end
9340
9341 C-----------------------------------------------------------------------------
9342       double precision function scalar(u,v)
9343 !DIR$ INLINEALWAYS scalar
9344 #ifndef OSF
9345 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9346 #endif
9347       implicit none
9348       double precision u(3),v(3)
9349 cd      double precision sc
9350 cd      integer i
9351 cd      sc=0.0d0
9352 cd      do i=1,3
9353 cd        sc=sc+u(i)*v(i)
9354 cd      enddo
9355 cd      scalar=sc
9356
9357       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9358       return
9359       end
9360 crc-------------------------------------------------
9361       SUBROUTINE MATVEC2(A1,V1,V2)
9362 !DIR$ INLINEALWAYS MATVEC2
9363 #ifndef OSF
9364 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9365 #endif
9366       implicit real*8 (a-h,o-z)
9367       include 'DIMENSIONS'
9368       DIMENSION A1(2,2),V1(2),V2(2)
9369 c      DO 1 I=1,2
9370 c        VI=0.0
9371 c        DO 3 K=1,2
9372 c    3     VI=VI+A1(I,K)*V1(K)
9373 c        Vaux(I)=VI
9374 c    1 CONTINUE
9375
9376       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9377       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9378
9379       v2(1)=vaux1
9380       v2(2)=vaux2
9381       END
9382 C---------------------------------------
9383       SUBROUTINE MATMAT2(A1,A2,A3)
9384 #ifndef OSF
9385 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9386 #endif
9387       implicit real*8 (a-h,o-z)
9388       include 'DIMENSIONS'
9389       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9390 c      DIMENSION AI3(2,2)
9391 c        DO  J=1,2
9392 c          A3IJ=0.0
9393 c          DO K=1,2
9394 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9395 c          enddo
9396 c          A3(I,J)=A3IJ
9397 c       enddo
9398 c      enddo
9399
9400       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9401       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9402       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9403       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9404
9405       A3(1,1)=AI3_11
9406       A3(2,1)=AI3_21
9407       A3(1,2)=AI3_12
9408       A3(2,2)=AI3_22
9409       END
9410
9411 c-------------------------------------------------------------------------
9412       double precision function scalar2(u,v)
9413 !DIR$ INLINEALWAYS scalar2
9414       implicit none
9415       double precision u(2),v(2)
9416       double precision sc
9417       integer i
9418       scalar2=u(1)*v(1)+u(2)*v(2)
9419       return
9420       end
9421
9422 C-----------------------------------------------------------------------------
9423
9424       subroutine transpose2(a,at)
9425 !DIR$ INLINEALWAYS transpose2
9426 #ifndef OSF
9427 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9428 #endif
9429       implicit none
9430       double precision a(2,2),at(2,2)
9431       at(1,1)=a(1,1)
9432       at(1,2)=a(2,1)
9433       at(2,1)=a(1,2)
9434       at(2,2)=a(2,2)
9435       return
9436       end
9437 c--------------------------------------------------------------------------
9438       subroutine transpose(n,a,at)
9439       implicit none
9440       integer n,i,j
9441       double precision a(n,n),at(n,n)
9442       do i=1,n
9443         do j=1,n
9444           at(j,i)=a(i,j)
9445         enddo
9446       enddo
9447       return
9448       end
9449 C---------------------------------------------------------------------------
9450       subroutine prodmat3(a1,a2,kk,transp,prod)
9451 !DIR$ INLINEALWAYS prodmat3
9452 #ifndef OSF
9453 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9454 #endif
9455       implicit none
9456       integer i,j
9457       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9458       logical transp
9459 crc      double precision auxmat(2,2),prod_(2,2)
9460
9461       if (transp) then
9462 crc        call transpose2(kk(1,1),auxmat(1,1))
9463 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9464 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9465
9466            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9467      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9468            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9469      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9470            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9471      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9472            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9473      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9474
9475       else
9476 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9477 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9478
9479            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9480      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9481            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9482      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9483            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9484      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9485            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9486      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9487
9488       endif
9489 c      call transpose2(a2(1,1),a2t(1,1))
9490
9491 crc      print *,transp
9492 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9493 crc      print *,((prod(i,j),i=1,2),j=1,2)
9494
9495       return
9496       end
9497