source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       call flush(iout)
  31       if (nfgtasks.gt.1) then
  32 #ifdef MPI
  33         time00=MPI_Wtime()
  34 #else
  35         time00=tcpu()
  36 #endif
  37 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  38         if (fg_rank.eq.0) then
  39           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  40 c          print *,"Processor",myrank," BROADCAST iorder"
  41 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  42 C FG slaves as WEIGHTS array.
  43           weights_(1)=wsc
  44           weights_(2)=wscp
  45           weights_(3)=welec
  46           weights_(4)=wcorr
  47           weights_(5)=wcorr5
  48           weights_(6)=wcorr6
  49           weights_(7)=wel_loc
  50           weights_(8)=wturn3
  51           weights_(9)=wturn4
  52           weights_(10)=wturn6
  53           weights_(11)=wang
  54           weights_(12)=wscloc
  55           weights_(13)=wtor
  56           weights_(14)=wtor_d
  57           weights_(15)=wstrain
  58           weights_(16)=wvdwpp
  59           weights_(17)=wbond
  60           weights_(18)=scal14
  61           weights_(21)=wsccor
  62           weights_(22)=wsct
  63 C FG Master broadcasts the WEIGHTS_ array
  64           call MPI_Bcast(weights_(1),n_ene,
  65      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  66         else
  67 C FG slaves receive the WEIGHTS array
  68           call MPI_Bcast(weights(1),n_ene,
  69      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  70           wsc=weights(1)
  71           wscp=weights(2)
  72           welec=weights(3)
  73           wcorr=weights(4)
  74           wcorr5=weights(5)
  75           wcorr6=weights(6)
  76           wel_loc=weights(7)
  77           wturn3=weights(8)
  78           wturn4=weights(9)
  79           wturn6=weights(10)
  80           wang=weights(11)
  81           wscloc=weights(12)
  82           wtor=weights(13)
  83           wtor_d=weights(14)
  84           wstrain=weights(15)
  85           wvdwpp=weights(16)
  86           wbond=weights(17)
  87           scal14=weights(18)
  88           wsccor=weights(21)
  89           wsct=weights(22)
  90         endif
  91         time_Bcast=time_Bcast+MPI_Wtime()-time00
  92         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  93 c        call chainbuild_cart
  94       endif
  95 c      write(iout,*) 'Processor',myrank,' calling etotal ipot=',ipot
  96 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  97 #else
  98 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  99 c        call int_from_cart1(.false.)
 100 c      endif
 101 #endif
 102 #ifndef DFA
 103       edfadis=0.0d0
 104       edfator=0.0d0
 105       edfanei=0.0d0
 106       edfabet=0.0d0
 107 #endif
 108 #ifdef TIMING
 109 #ifdef MPI
 110       time00=MPI_Wtime()
 111 #else
 112       time00=tcpu()
 113 #endif
 114 #endif
 115 C
 116 C Compute the side-chain and electrostatic interaction energy
 117 C
 118       goto (101,102,103,104,105,106) ipot
 119 C Lennard-Jones potential.
 120   101 call elj(evdw,evdw_p,evdw_m)
 121 cd    print '(a)','Exit ELJ'
 122       goto 107
 123 C Lennard-Jones-Kihara potential (shifted).
 124   102 call eljk(evdw,evdw_p,evdw_m)
 125       goto 107
 126 C Berne-Pechukas potential (dilated LJ, angular dependence).
 127   103 call ebp(evdw,evdw_p,evdw_m)
 128       goto 107
 129 C Gay-Berne potential (shifted LJ, angular dependence).
 130   104 call egb(evdw,evdw_p,evdw_m)
 131       goto 107
 132 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 133   105 call egbv(evdw,evdw_p,evdw_m)
 134       goto 107
 135 C Soft-sphere potential
 136   106 call e_softsphere(evdw)
 137 C
 138 C Calculate electrostatic (H-bonding) energy of the main chain.
 139 C
 140   107 continue
 141 #ifdef DFA
 142 C     BARTEK for dfa test!
 143       if (wdfa_dist.gt.0) then
 144         call edfad(edfadis)
 145       else
 146         edfadis=0
 147       endif
 148 c      print*, 'edfad is finished!', edfadis
 149       if (wdfa_tor.gt.0) then
 150         call edfat(edfator)
 151       else
 152         edfator=0
 153       endif
 154 c      print*, 'edfat is finished!', edfator
 155       if (wdfa_nei.gt.0) then
 156         call edfan(edfanei)
 157       else
 158         edfanei=0
 159       endif
 160 c      print*, 'edfan is finished!', edfanei
 161       if (wdfa_beta.gt.0) then
 162         call edfab(edfabet)
 163       else
 164         edfabet=0
 165       endif
 166 #endif
 167 c      print*, 'edfab is finished!', edfabet
 168 cmc
 169 cmc Sep-06: egb takes care of dynamic ss bonds too
 170 cmc
 171 c      if (dyn_ss) call dyn_set_nss
 172
 173 c      print *,"Processor",myrank," computed USCSC"
 174 #ifdef TIMING
 175 #ifdef MPI
 176       time01=MPI_Wtime()
 177 #else
 178       time00=tcpu()
 179 #endif
 180 #endif
 181       call vec_and_deriv
 182 #ifdef TIMING
 183 #ifdef MPI
 184       time_vec=time_vec+MPI_Wtime()-time01
 185 #else
 186       time_vec=time_vec+tcpu()-time01
 187 #endif
 188 #endif
 189 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 190       if (ipot.lt.6) then
 191 #ifdef SPLITELE
 192          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 193      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 194      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 195      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 196 #else
 197          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 198      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 199      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 200      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 201 #endif
 202             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 203          else
 204             ees=0.0d0
 205             evdw1=0.0d0
 206             eel_loc=0.0d0
 207             eello_turn3=0.0d0
 208             eello_turn4=0.0d0
 209          endif
 210       else
 211 c        write (iout,*) "Soft-spheer ELEC potential"
 212         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 213      &   eello_turn4)
 214       endif
 215 c      print *,"Processor",myrank," computed UELEC"
 216 C
 217 C Calculate excluded-volume interaction energy between peptide groups
 218 C and side chains.
 219 C
 220       if (ipot.lt.6) then
 221        if(wscp.gt.0d0) then
 222         call escp(evdw2,evdw2_14)
 223        else
 224         evdw2=0
 225         evdw2_14=0
 226        endif
 227       else
 228 c        write (iout,*) "Soft-sphere SCP potential"
 229         call escp_soft_sphere(evdw2,evdw2_14)
 230       endif
 231 c
 232 c Calculate the bond-stretching energy
 233 c
 234       call ebond(estr)
 235 C
 236 C Calculate the disulfide-bridge and other energy and the contributions
 237 C from other distance constraints.
 238 cd    print *,'Calling EHPB'
 239       call edis(ehpb)
 240 cd    print *,'EHPB exitted succesfully.'
 241 C
 242 C Calculate the virtual-bond-angle energy.
 243 C
 244       if (wang.gt.0d0) then
 245         call ebend(ebe)
 246       else
 247         ebe=0
 248       endif
 249 c      print *,"Processor",myrank," computed UB"
 250 C
 251 C Calculate the SC local energy.
 252 C
 253       call esc(escloc)
 254 c      print *,"Processor",myrank," computed USC"
 255 C
 256 C Calculate the virtual-bond torsional energy.
 257 C
 258 cd    print *,'nterm=',nterm
 259       if (wtor.gt.0) then
 260        call etor(etors,edihcnstr)
 261       else
 262        etors=0
 263        edihcnstr=0
 264       endif
 265
 266       if (constr_homology.ge.1.and.waga_homology(iset).ne.0d0) then
 267         call e_modeller(ehomology_constr)
 268 c        print *,'iset=',iset,'me=',me,ehomology_constr,
 269 c     &  'Processor',fg_rank,' CG group',kolor,
 270 c     &  ' absolute rank',MyRank
 271       else
 272         ehomology_constr=0.0d0
 273       endif
 274
 275
 276 c      write(iout,*) ehomology_constr
 277 c      print *,"Processor",myrank," computed Utor"
 278 C
 279 C 6/23/01 Calculate double-torsional energy
 280 C
 281       if (wtor_d.gt.0) then
 282        call etor_d(etors_d)
 283       else
 284        etors_d=0
 285       endif
 286 c      print *,"Processor",myrank," computed Utord"
 287 C
 288 C 21/5/07 Calculate local sicdechain correlation energy
 289 C
 290       if (wsccor.gt.0.0d0) then
 291         call eback_sc_corr(esccor)
 292       else
 293         esccor=0.0d0
 294       endif
 295 c      print *,"Processor",myrank," computed Usccorr"
 296 C
 297 C 12/1/95 Multi-body terms
 298 C
 299       n_corr=0
 300       n_corr1=0
 301       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 302      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 303          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 304 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 305 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 306       else
 307          ecorr=0.0d0
 308          ecorr5=0.0d0
 309          ecorr6=0.0d0
 310          eturn6=0.0d0
 311       endif
 312       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 313          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 314 cd         write (iout,*) "multibody_hb ecorr",ecorr
 315       endif
 316 c      print *,"Processor",myrank," computed Ucorr"
 317 C
 318 C If performing constraint dynamics, call the constraint energy
 319 C  after the equilibration time
 320       if(usampl.and.totT.gt.eq_time) then
 321 c         write (iout,*) "CALL TO ECONSTR_BACK"
 322          call EconstrQ
 323          call Econstr_back
 324       else
 325          Uconst=0.0d0
 326          Uconst_back=0.0d0
 327       endif
 328 #ifdef TIMING
 329 #ifdef MPI
 330       time_enecalc=time_enecalc+MPI_Wtime()-time00
 331 #else
 332       time_enecalc=time_enecalc+tcpu()-time00
 333 #endif
 334 #endif
 335 c      print *,"Processor",myrank," computed Uconstr"
 336 #ifdef TIMING
 337 #ifdef MPI
 338       time00=MPI_Wtime()
 339 #else
 340       time00=tcpu()
 341 #endif
 342 #endif
 343 c
 344 C Sum the energies
 345 C
 346       energia(1)=evdw
 347 #ifdef SCP14
 348       energia(2)=evdw2-evdw2_14
 349       energia(18)=evdw2_14
 350 #else
 351       energia(2)=evdw2
 352       energia(18)=0.0d0
 353 #endif
 354 #ifdef SPLITELE
 355       energia(3)=ees
 356       energia(16)=evdw1
 357 #else
 358       energia(3)=ees+evdw1
 359       energia(16)=0.0d0
 360 #endif
 361       energia(4)=ecorr
 362       energia(5)=ecorr5
 363       energia(6)=ecorr6
 364       energia(7)=eel_loc
 365       energia(8)=eello_turn3
 366       energia(9)=eello_turn4
 367       energia(10)=eturn6
 368       energia(11)=ebe
 369       energia(12)=escloc
 370       energia(13)=etors
 371       energia(14)=etors_d
 372       energia(15)=ehpb
 373       energia(19)=edihcnstr
 374       energia(17)=estr
 375       energia(20)=Uconst+Uconst_back
 376       energia(21)=esccor
 377       energia(22)=evdw_p
 378       energia(23)=evdw_m
 379       energia(24)=ehomology_constr
 380       energia(25)=edfadis
 381       energia(26)=edfator
 382       energia(27)=edfanei
 383       energia(28)=edfabet
 384 c      print *," Processor",myrank," calls SUM_ENERGY"
 385       call sum_energy(energia,.true.)
 386       if (dyn_ss) call dyn_set_nss
 387 c      print *," Processor",myrank," left SUM_ENERGY"
 388 #ifdef TIMING
 389 #ifdef MPI
 390       time_sumene=time_sumene+MPI_Wtime()-time00
 391 #else
 392       time_sumene=time_sumene+tcpu()-time00
 393 #endif
 394 #endif
 395       return
 396       end
 397 c-------------------------------------------------------------------------------
 398       subroutine sum_energy(energia,reduce)
 399       implicit real*8 (a-h,o-z)
 400       include 'DIMENSIONS'
 401 #ifndef ISNAN
 402       external proc_proc
 403 #ifdef WINPGI
 404 cMS$ATTRIBUTES C ::  proc_proc
 405 #endif
 406 #endif
 407 #ifdef MPI
 408       include "mpif.h"
 409 #endif
 410       include 'COMMON.SETUP'
 411       include 'COMMON.IOUNITS'
 412       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 413       include 'COMMON.FFIELD'
 414       include 'COMMON.DERIV'
 415       include 'COMMON.INTERACT'
 416       include 'COMMON.SBRIDGE'
 417       include 'COMMON.CHAIN'
 418       include 'COMMON.VAR'
 419       include 'COMMON.CONTROL'
 420       include 'COMMON.TIME1'
 421       logical reduce
 422 #ifdef MPI
 423       if (nfgtasks.gt.1 .and. reduce) then
 424 #ifdef DEBUG
 425         write (iout,*) "energies before REDUCE"
 426         call enerprint(energia)
 427         call flush(iout)
 428 #endif
 429         do i=0,n_ene
 430           enebuff(i)=energia(i)
 431         enddo
 432         time00=MPI_Wtime()
 433         call MPI_Barrier(FG_COMM,IERR)
 434         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 435         time00=MPI_Wtime()
 436         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 437      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 438 #ifdef DEBUG
 439         write (iout,*) "energies after REDUCE"
 440         call enerprint(energia)
 441         call flush(iout)
 442 #endif
 443         time_Reduce=time_Reduce+MPI_Wtime()-time00
 444       endif
 445       if (fg_rank.eq.0) then
 446 #endif
 447 #ifdef TSCSC
 448       evdw=energia(22)+wsct*energia(23)
 449 #else
 450       evdw=energia(1)
 451 #endif
 452 #ifdef SCP14
 453       evdw2=energia(2)+energia(18)
 454       evdw2_14=energia(18)
 455 #else
 456       evdw2=energia(2)
 457 #endif
 458 #ifdef SPLITELE
 459       ees=energia(3)
 460       evdw1=energia(16)
 461 #else
 462       ees=energia(3)
 463       evdw1=0.0d0
 464 #endif
 465       ecorr=energia(4)
 466       ecorr5=energia(5)
 467       ecorr6=energia(6)
 468       eel_loc=energia(7)
 469       eello_turn3=energia(8)
 470       eello_turn4=energia(9)
 471       eturn6=energia(10)
 472       ebe=energia(11)
 473       escloc=energia(12)
 474       etors=energia(13)
 475       etors_d=energia(14)
 476       ehpb=energia(15)
 477       edihcnstr=energia(19)
 478       estr=energia(17)
 479       Uconst=energia(20)
 480       esccor=energia(21)
 481       ehomology_constr=energia(24)
 482       edfadis=energia(25)
 483       edfator=energia(26)
 484       edfanei=energia(27)
 485       edfabet=energia(28)
 486 #ifdef SPLITELE
 487       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 488      & +wang*ebe+wtor*etors+wscloc*escloc
 489      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 490      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 491      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 492      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 493      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 494      & +wdfa_beta*edfabet
 495 #else
 496       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 497      & +wang*ebe+wtor*etors+wscloc*escloc
 498      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 499      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 500      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 501      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 502      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 503      & +wdfa_beta*edfabet
 504 #endif
 505       energia(0)=etot
 506 c detecting NaNQ
 507 #ifdef ISNAN
 508 #ifdef AIX
 509       if (isnan(etot).ne.0) energia(0)=1.0d+99
 510 #else
 511       if (isnan(etot)) energia(0)=1.0d+99
 512 #endif
 513 #else
 514       i=0
 515 #ifdef WINPGI
 516       idumm=proc_proc(etot,i)
 517 #else
 518       call proc_proc(etot,i)
 519 #endif
 520       if(i.eq.1)energia(0)=1.0d+99
 521 #endif
 522 #ifdef MPI
 523       endif
 524 #endif
 525       return
 526       end
 527 c-------------------------------------------------------------------------------
 528       subroutine sum_gradient
 529       implicit real*8 (a-h,o-z)
 530       include 'DIMENSIONS'
 531 #ifndef ISNAN
 532       external proc_proc
 533 #ifdef WINPGI
 534 cMS$ATTRIBUTES C ::  proc_proc
 535 #endif
 536 #endif
 537 #ifdef MPI
 538       include 'mpif.h'
 539 #endif
 540       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 541      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 542       include 'COMMON.SETUP'
 543       include 'COMMON.IOUNITS'
 544       include 'COMMON.FFIELD'
 545       include 'COMMON.DERIV'
 546       include 'COMMON.INTERACT'
 547       include 'COMMON.SBRIDGE'
 548       include 'COMMON.CHAIN'
 549       include 'COMMON.VAR'
 550       include 'COMMON.CONTROL'
 551       include 'COMMON.TIME1'
 552       include 'COMMON.MAXGRAD'
 553       include 'COMMON.SCCOR'
 554       include 'COMMON.MD'
 555 #ifdef TIMING
 556 #ifdef MPI
 557       time01=MPI_Wtime()
 558 #else
 559       time01=tcpu()
 560 #endif
 561 #endif
 562 #ifdef DEBUG
 563       write (iout,*) "sum_gradient gvdwc, gvdwx"
 564       do i=1,nres
 565         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 566      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 567      &   (gvdwcT(j,i),j=1,3)
 568       enddo
 569       call flush(iout)
 570 #endif
 571 #ifdef MPI
 572 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 573         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 574      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 575 #endif
 576 C
 577 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 578 C            in virtual-bond-vector coordinates
 579 C
 580 #ifdef DEBUG
 581 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 582 c      do i=1,nres-1
 583 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 584 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 585 c      enddo
 586 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 587 c      do i=1,nres-1
 588 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 589 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 590 c      enddo
 591       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 592       do i=1,nres
 593         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 594      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 595      &   g_corr5_loc(i)
 596       enddo
 597       call flush(iout)
 598 #endif
 599 #ifdef SPLITELE
 600 #ifdef TSCSC
 601       do i=1,nct
 602         do j=1,3
 603           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 604      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 605      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 606      &                wel_loc*gel_loc_long(j,i)+
 607      &                wcorr*gradcorr_long(j,i)+
 608      &                wcorr5*gradcorr5_long(j,i)+
 609      &                wcorr6*gradcorr6_long(j,i)+
 610      &                wturn6*gcorr6_turn_long(j,i)+
 611      &                wstrain*ghpbc(j,i)+
 612      &                wdfa_dist*gdfad(j,i)+
 613      &                wdfa_tor*gdfat(j,i)+
 614      &                wdfa_nei*gdfan(j,i)+
 615      &                wdfa_beta*gdfab(j,i)
 616         enddo
 617       enddo
 618 #else
 619       do i=1,nct
 620         do j=1,3
 621           gradbufc(j,i)=wsc*gvdwc(j,i)+
 622      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 623      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 624      &                wel_loc*gel_loc_long(j,i)+
 625      &                wcorr*gradcorr_long(j,i)+
 626      &                wcorr5*gradcorr5_long(j,i)+
 627      &                wcorr6*gradcorr6_long(j,i)+
 628      &                wturn6*gcorr6_turn_long(j,i)+
 629      &                wstrain*ghpbc(j,i)+
 630      &                wdfa_dist*gdfad(j,i)+
 631      &                wdfa_tor*gdfat(j,i)+
 632      &                wdfa_nei*gdfan(j,i)+
 633      &                wdfa_beta*gdfab(j,i)
 634         enddo
 635       enddo
 636 #endif
 637 #else
 638       do i=1,nct
 639         do j=1,3
 640           gradbufc(j,i)=wsc*gvdwc(j,i)+
 641      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 642      &                welec*gelc_long(j,i)+
 643      &                wbond*gradb(j,i)+
 644      &                wel_loc*gel_loc_long(j,i)+
 645      &                wcorr*gradcorr_long(j,i)+
 646      &                wcorr5*gradcorr5_long(j,i)+
 647      &                wcorr6*gradcorr6_long(j,i)+
 648      &                wturn6*gcorr6_turn_long(j,i)+
 649      &                wstrain*ghpbc(j,i)+
 650      &                wdfa_dist*gdfad(j,i)+
 651      &                wdfa_tor*gdfat(j,i)+
 652      &                wdfa_nei*gdfan(j,i)+
 653      &                wdfa_beta*gdfab(j,i)
 654         enddo
 655       enddo
 656 #endif
 657 #ifdef MPI
 658       if (nfgtasks.gt.1) then
 659       time00=MPI_Wtime()
 660 #ifdef DEBUG
 661       write (iout,*) "gradbufc before allreduce"
 662       do i=1,nres
 663         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 664       enddo
 665       call flush(iout)
 666 #endif
 667       do i=1,nres
 668         do j=1,3
 669           gradbufc_sum(j,i)=gradbufc(j,i)
 670         enddo
 671       enddo
 672 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 673 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 674 c      time_reduce=time_reduce+MPI_Wtime()-time00
 675 #ifdef DEBUG
 676 c      write (iout,*) "gradbufc_sum after allreduce"
 677 c      do i=1,nres
 678 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 679 c      enddo
 680 c      call flush(iout)
 681 #endif
 682 #ifdef TIMING
 683 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 684 #endif
 685       do i=nnt,nres
 686         do k=1,3
 687           gradbufc(k,i)=0.0d0
 688         enddo
 689       enddo
 690 #ifdef DEBUG
 691       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 692       write (iout,*) (i," jgrad_start",jgrad_start(i),
 693      &                  " jgrad_end  ",jgrad_end(i),
 694      &                  i=igrad_start,igrad_end)
 695 #endif
 696 c
 697 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 698 c do not parallelize this part.
 699 c
 700 c      do i=igrad_start,igrad_end
 701 c        do j=jgrad_start(i),jgrad_end(i)
 702 c          do k=1,3
 703 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 704 c          enddo
 705 c        enddo
 706 c      enddo
 707       do j=1,3
 708         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 709       enddo
 710       do i=nres-2,nnt,-1
 711         do j=1,3
 712           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 713         enddo
 714       enddo
 715 #ifdef DEBUG
 716       write (iout,*) "gradbufc after summing"
 717       do i=1,nres
 718         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 719       enddo
 720       call flush(iout)
 721 #endif
 722       else
 723 #endif
 724 #ifdef DEBUG
 725       write (iout,*) "gradbufc"
 726       do i=1,nres
 727         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 728       enddo
 729       call flush(iout)
 730 #endif
 731       do i=1,nres
 732         do j=1,3
 733           gradbufc_sum(j,i)=gradbufc(j,i)
 734           gradbufc(j,i)=0.0d0
 735         enddo
 736       enddo
 737       do j=1,3
 738         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 739       enddo
 740       do i=nres-2,nnt,-1
 741         do j=1,3
 742           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 743         enddo
 744       enddo
 745 c      do i=nnt,nres-1
 746 c        do k=1,3
 747 c          gradbufc(k,i)=0.0d0
 748 c        enddo
 749 c        do j=i+1,nres
 750 c          do k=1,3
 751 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 752 c          enddo
 753 c        enddo
 754 c      enddo
 755 #ifdef DEBUG
 756       write (iout,*) "gradbufc after summing"
 757       do i=1,nres
 758         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 759       enddo
 760       call flush(iout)
 761 #endif
 762 #ifdef MPI
 763       endif
 764 #endif
 765       do k=1,3
 766         gradbufc(k,nres)=0.0d0
 767       enddo
 768       do i=1,nct
 769         do j=1,3
 770 #ifdef SPLITELE
 771           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 772      &                wel_loc*gel_loc(j,i)+
 773      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 774      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 775      &                wel_loc*gel_loc_long(j,i)+
 776      &                wcorr*gradcorr_long(j,i)+
 777      &                wcorr5*gradcorr5_long(j,i)+
 778      &                wcorr6*gradcorr6_long(j,i)+
 779      &                wturn6*gcorr6_turn_long(j,i))+
 780      &                wbond*gradb(j,i)+
 781      &                wcorr*gradcorr(j,i)+
 782      &                wturn3*gcorr3_turn(j,i)+
 783      &                wturn4*gcorr4_turn(j,i)+
 784      &                wcorr5*gradcorr5(j,i)+
 785      &                wcorr6*gradcorr6(j,i)+
 786      &                wturn6*gcorr6_turn(j,i)+
 787      &                wsccor*gsccorc(j,i)
 788      &               +wscloc*gscloc(j,i)
 789 #else
 790           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 791      &                wel_loc*gel_loc(j,i)+
 792      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 793      &                welec*gelc_long(j,i)+
 794      &                wel_loc*gel_loc_long(j,i)+
 795      &                wcorr*gcorr_long(j,i)+
 796      &                wcorr5*gradcorr5_long(j,i)+
 797      &                wcorr6*gradcorr6_long(j,i)+
 798      &                wturn6*gcorr6_turn_long(j,i))+
 799      &                wbond*gradb(j,i)+
 800      &                wcorr*gradcorr(j,i)+
 801      &                wturn3*gcorr3_turn(j,i)+
 802      &                wturn4*gcorr4_turn(j,i)+
 803      &                wcorr5*gradcorr5(j,i)+
 804      &                wcorr6*gradcorr6(j,i)+
 805      &                wturn6*gcorr6_turn(j,i)+
 806      &                wsccor*gsccorc(j,i)
 807      &               +wscloc*gscloc(j,i)
 808 #endif
 809 #ifdef TSCSC
 810           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 811      &                  wscp*gradx_scp(j,i)+
 812      &                  wbond*gradbx(j,i)+
 813      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 814      &                  wsccor*gsccorx(j,i)
 815      &                 +wscloc*gsclocx(j,i)
 816 #else
 817           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 818      &                  wbond*gradbx(j,i)+
 819      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 820      &                  wsccor*gsccorx(j,i)
 821      &                 +wscloc*gsclocx(j,i)
 822 #endif
 823         enddo
 824       enddo
 825       if (constr_homology.gt.0.and.waga_homology(iset).ne.0d0) then
 826         do i=1,nct
 827           do j=1,3
 828             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
 829             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
 830           enddo
 831         enddo
 832       endif
 833 #ifdef DEBUG
 834       write (iout,*) "gloc before adding corr"
 835       do i=1,4*nres
 836         write (iout,*) i,gloc(i,icg)
 837       enddo
 838 #endif
 839       do i=1,nres-3
 840         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 841      &   +wcorr5*g_corr5_loc(i)
 842      &   +wcorr6*g_corr6_loc(i)
 843      &   +wturn4*gel_loc_turn4(i)
 844      &   +wturn3*gel_loc_turn3(i)
 845      &   +wturn6*gel_loc_turn6(i)
 846      &   +wel_loc*gel_loc_loc(i)
 847       enddo
 848 #ifdef DEBUG
 849       write (iout,*) "gloc after adding corr"
 850       do i=1,4*nres
 851         write (iout,*) i,gloc(i,icg)
 852       enddo
 853 #endif
 854 #ifdef MPI
 855       if (nfgtasks.gt.1) then
 856         do j=1,3
 857           do i=1,nres
 858             gradbufc(j,i)=gradc(j,i,icg)
 859             gradbufx(j,i)=gradx(j,i,icg)
 860           enddo
 861         enddo
 862         do i=1,4*nres
 863           glocbuf(i)=gloc(i,icg)
 864         enddo
 865 #ifdef DEBUG
 866       write (iout,*) "gloc_sc before reduce"
 867       do i=1,nres
 868        do j=1,3
 869         write (iout,*) i,j,gloc_sc(j,i,icg)
 870        enddo
 871       enddo
 872 #endif
 873         do i=1,nres
 874          do j=1,3
 875           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 876          enddo
 877         enddo
 878         time00=MPI_Wtime()
 879         call MPI_Barrier(FG_COMM,IERR)
 880         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 881         time00=MPI_Wtime()
 882         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 883      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 884         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 885      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 886         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 887      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 888         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 889      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 890         time_reduce=time_reduce+MPI_Wtime()-time00
 891 #ifdef DEBUG
 892       write (iout,*) "gloc_sc after reduce"
 893       do i=1,nres
 894        do j=1,3
 895         write (iout,*) i,j,gloc_sc(j,i,icg)
 896        enddo
 897       enddo
 898 #endif
 899 #ifdef DEBUG
 900       write (iout,*) "gloc after reduce"
 901       do i=1,4*nres
 902         write (iout,*) i,gloc(i,icg)
 903       enddo
 904 #endif
 905       endif
 906 #endif
 907       if (gnorm_check) then
 908 c
 909 c Compute the maximum elements of the gradient
 910 c
 911       gvdwc_max=0.0d0
 912       gvdwc_scp_max=0.0d0
 913       gelc_max=0.0d0
 914       gvdwpp_max=0.0d0
 915       gradb_max=0.0d0
 916       ghpbc_max=0.0d0
 917       gradcorr_max=0.0d0
 918       gel_loc_max=0.0d0
 919       gcorr3_turn_max=0.0d0
 920       gcorr4_turn_max=0.0d0
 921       gradcorr5_max=0.0d0
 922       gradcorr6_max=0.0d0
 923       gcorr6_turn_max=0.0d0
 924       gsccorc_max=0.0d0
 925       gscloc_max=0.0d0
 926       gvdwx_max=0.0d0
 927       gradx_scp_max=0.0d0
 928       ghpbx_max=0.0d0
 929       gradxorr_max=0.0d0
 930       gsccorx_max=0.0d0
 931       gsclocx_max=0.0d0
 932       do i=1,nct
 933         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 934         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 935 #ifdef TSCSC
 936         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 937         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 938 #endif
 939         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 940         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 941      &   gvdwc_scp_max=gvdwc_scp_norm
 942         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 943         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 944         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 945         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 946         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 947         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 948         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 949         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 950         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 951         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 952         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 953         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 954         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 955      &    gcorr3_turn(1,i)))
 956         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 957      &    gcorr3_turn_max=gcorr3_turn_norm
 958         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 959      &    gcorr4_turn(1,i)))
 960         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 961      &    gcorr4_turn_max=gcorr4_turn_norm
 962         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 963         if (gradcorr5_norm.gt.gradcorr5_max)
 964      &    gradcorr5_max=gradcorr5_norm
 965         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 966         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 967         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 968      &    gcorr6_turn(1,i)))
 969         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 970      &    gcorr6_turn_max=gcorr6_turn_norm
 971         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 972         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 973         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 974         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 975         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 976         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 977 #ifdef TSCSC
 978         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 979         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 980 #endif
 981         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 982         if (gradx_scp_norm.gt.gradx_scp_max)
 983      &    gradx_scp_max=gradx_scp_norm
 984         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 985         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 986         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 987         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 988         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 989         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 990         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 991         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 992       enddo
 993       if (gradout) then
 994 #ifdef AIX
 995         open(istat,file=statname,position="append")
 996 #else
 997         open(istat,file=statname,access="append")
 998 #endif
 999         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1000      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1001      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1002      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1003      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1004      &     gsccorx_max,gsclocx_max
1005         close(istat)
1006         if (gvdwc_max.gt.1.0d4) then
1007           write (iout,*) "gvdwc gvdwx gradb gradbx"
1008           do i=nnt,nct
1009             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1010      &        gradb(j,i),gradbx(j,i),j=1,3)
1011           enddo
1012           call pdbout(0.0d0,'cipiszcze',iout)
1013           call flush(iout)
1014         endif
1015       endif
1016       endif
1017 #ifdef DEBUG
1018       write (iout,*) "gradc gradx gloc"
1019       do i=1,nres
1020         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1021      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1022       enddo
1023 #endif
1024 #ifdef TIMING
1025 #ifdef MPI
1026       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1027 #else
1028       time_sumgradient=time_sumgradient+tcpu()-time01
1029 #endif
1030 #endif
1031       return
1032       end
1033 c-------------------------------------------------------------------------------
1034       subroutine rescale_weights(t_bath)
1035       implicit real*8 (a-h,o-z)
1036       include 'DIMENSIONS'
1037       include 'COMMON.IOUNITS'
1038       include 'COMMON.FFIELD'
1039       include 'COMMON.SBRIDGE'
1040       double precision kfac /2.4d0/
1041       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1042 c      facT=temp0/t_bath
1043 c      facT=2*temp0/(t_bath+temp0)
1044       if (rescale_mode.eq.0) then
1045         facT=1.0d0
1046         facT2=1.0d0
1047         facT3=1.0d0
1048         facT4=1.0d0
1049         facT5=1.0d0
1050       else if (rescale_mode.eq.1) then
1051         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1052         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1053         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1054         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1055         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1056       else if (rescale_mode.eq.2) then
1057         x=t_bath/temp0
1058         x2=x*x
1059         x3=x2*x
1060         x4=x3*x
1061         x5=x4*x
1062         facT=licznik/dlog(dexp(x)+dexp(-x))
1063         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1064         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1065         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1066         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1067       else
1068         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1069         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1070 #ifdef MPI
1071        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1072 #endif
1073        stop 555
1074       endif
1075       welec=weights(3)*fact
1076       wcorr=weights(4)*fact3
1077       wcorr5=weights(5)*fact4
1078       wcorr6=weights(6)*fact5
1079       wel_loc=weights(7)*fact2
1080       wturn3=weights(8)*fact2
1081       wturn4=weights(9)*fact3
1082       wturn6=weights(10)*fact5
1083       wtor=weights(13)*fact
1084       wtor_d=weights(14)*fact2
1085       wsccor=weights(21)*fact
1086 #ifdef TSCSC
1087 c      wsct=t_bath/temp0
1088       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1089 #endif
1090       return
1091       end
1092 C------------------------------------------------------------------------
1093       subroutine enerprint(energia)
1094       implicit real*8 (a-h,o-z)
1095       include 'DIMENSIONS'
1096       include 'COMMON.IOUNITS'
1097       include 'COMMON.FFIELD'
1098       include 'COMMON.SBRIDGE'
1099       include 'COMMON.MD'
1100       double precision energia(0:n_ene)
1101       etot=energia(0)
1102 #ifdef TSCSC
1103       evdw=energia(22)+wsct*energia(23)
1104 #else
1105       evdw=energia(1)
1106 #endif
1107       evdw2=energia(2)
1108 #ifdef SCP14
1109       evdw2=energia(2)+energia(18)
1110 #else
1111       evdw2=energia(2)
1112 #endif
1113       ees=energia(3)
1114 #ifdef SPLITELE
1115       evdw1=energia(16)
1116 #endif
1117       ecorr=energia(4)
1118       ecorr5=energia(5)
1119       ecorr6=energia(6)
1120       eel_loc=energia(7)
1121       eello_turn3=energia(8)
1122       eello_turn4=energia(9)
1123       eello_turn6=energia(10)
1124       ebe=energia(11)
1125       escloc=energia(12)
1126       etors=energia(13)
1127       etors_d=energia(14)
1128       ehpb=energia(15)
1129       edihcnstr=energia(19)
1130       estr=energia(17)
1131       Uconst=energia(20)
1132       esccor=energia(21)
1133       ehomology_constr=energia(24)
1134 C     Bartek
1135       edfadis = energia(25)
1136       edfator = energia(26)
1137       edfanei = energia(27)
1138       edfabet = energia(28)
1139
1140 #ifdef SPLITELE
1141       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1142      &  estr,wbond,ebe,wang,
1143      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1144      &  ecorr,wcorr,
1145      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1146      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1147      &  edihcnstr,ehomology_constr, ebr*nss,
1148      &  Uconst,edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1149      &  edfabet,wdfa_beta,etot
1150    10 format (/'Virtual-chain energies:'//
1151      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1152      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1153      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1154      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1155      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1156      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1157      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1158      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1159      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1160      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1161      & ' (SS bridges & dist. cnstr.)'/
1162      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1163      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1164      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1165      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1166      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1167      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1168      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1169      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1170      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1171      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1172      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1173      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1174      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1175      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1176      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1177      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1178      & 'ETOT=  ',1pE16.6,' (total)')
1179 #else
1180       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1181      &  estr,wbond,ebe,wang,
1182      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1183      &  ecorr,wcorr,
1184      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1185      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1186      &  ehomology_constr,ebr*nss,Uconst,edfadis,wdfa_dist,edfator,
1187      &  wdfa_tor,edfanei,wdfa_nei,edfabet,wdfa_beta,
1188      &  etot
1189    10 format (/'Virtual-chain energies:'//
1190      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1191      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1192      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1193      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1194      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1195      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1196      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1197      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1198      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1199      & ' (SS bridges & dist. cnstr.)'/
1200      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1201      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1202      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1203      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1204      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1205      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1206      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1207      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1208      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1209      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1210      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1211      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1212      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
1213      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
1214      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
1215      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
1216      & 'ETOT=  ',1pE16.6,' (total)')
1217 #endif
1218       return
1219       end
1220 C-----------------------------------------------------------------------
1221       subroutine elj(evdw,evdw_p,evdw_m)
1222 C
1223 C This subroutine calculates the interaction energy of nonbonded side chains
1224 C assuming the LJ potential of interaction.
1225 C
1226       implicit real*8 (a-h,o-z)
1227       include 'DIMENSIONS'
1228       parameter (accur=1.0d-10)
1229       include 'COMMON.GEO'
1230       include 'COMMON.VAR'
1231       include 'COMMON.LOCAL'
1232       include 'COMMON.CHAIN'
1233       include 'COMMON.DERIV'
1234       include 'COMMON.INTERACT'
1235       include 'COMMON.TORSION'
1236       include 'COMMON.SBRIDGE'
1237       include 'COMMON.NAMES'
1238       include 'COMMON.IOUNITS'
1239       include 'COMMON.CONTACTS'
1240       dimension gg(3)
1241 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1242       evdw=0.0D0
1243       do i=iatsc_s,iatsc_e
1244         itypi=itype(i)
1245         itypi1=itype(i+1)
1246         xi=c(1,nres+i)
1247         yi=c(2,nres+i)
1248         zi=c(3,nres+i)
1249 C Change 12/1/95
1250         num_conti=0
1251 C
1252 C Calculate SC interaction energy.
1253 C
1254         do iint=1,nint_gr(i)
1255 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1256 cd   &                  'iend=',iend(i,iint)
1257           do j=istart(i,iint),iend(i,iint)
1258             itypj=itype(j)
1259             xj=c(1,nres+j)-xi
1260             yj=c(2,nres+j)-yi
1261             zj=c(3,nres+j)-zi
1262 C Change 12/1/95 to calculate four-body interactions
1263             rij=xj*xj+yj*yj+zj*zj
1264             rrij=1.0D0/rij
1265 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1266             eps0ij=eps(itypi,itypj)
1267             fac=rrij**expon2
1268             e1=fac*fac*aa(itypi,itypj)
1269             e2=fac*bb(itypi,itypj)
1270             evdwij=e1+e2
1271 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1272 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1273 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1274 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1275 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1276 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1277 #ifdef TSCSC
1278             if (bb(itypi,itypj).gt.0) then
1279                evdw_p=evdw_p+evdwij
1280             else
1281                evdw_m=evdw_m+evdwij
1282             endif
1283 #else
1284             evdw=evdw+evdwij
1285 #endif
1286 C
1287 C Calculate the components of the gradient in DC and X
1288 C
1289             fac=-rrij*(e1+evdwij)
1290             gg(1)=xj*fac
1291             gg(2)=yj*fac
1292             gg(3)=zj*fac
1293 #ifdef TSCSC
1294             if (bb(itypi,itypj).gt.0.0d0) then
1295               do k=1,3
1296                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1297                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1298                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1299                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1300               enddo
1301             else
1302               do k=1,3
1303                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1304                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1305                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1306                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1307               enddo
1308             endif
1309 #else
1310             do k=1,3
1311               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1312               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1313               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1314               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1315             enddo
1316 #endif
1317 cgrad            do k=i,j-1
1318 cgrad              do l=1,3
1319 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1320 cgrad              enddo
1321 cgrad            enddo
1322 C
1323 C 12/1/95, revised on 5/20/97
1324 C
1325 C Calculate the contact function. The ith column of the array JCONT will
1326 C contain the numbers of atoms that make contacts with the atom I (of numbers
1327 C greater than I). The arrays FACONT and GACONT will contain the values of
1328 C the contact function and its derivative.
1329 C
1330 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1331 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1332 C Uncomment next line, if the correlation interactions are contact function only
1333             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1334               rij=dsqrt(rij)
1335               sigij=sigma(itypi,itypj)
1336               r0ij=rs0(itypi,itypj)
1337 C
1338 C Check whether the SC's are not too far to make a contact.
1339 C
1340               rcut=1.5d0*r0ij
1341               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1342 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1343 C
1344               if (fcont.gt.0.0D0) then
1345 C If the SC-SC distance if close to sigma, apply spline.
1346 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1347 cAdam &             fcont1,fprimcont1)
1348 cAdam           fcont1=1.0d0-fcont1
1349 cAdam           if (fcont1.gt.0.0d0) then
1350 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1351 cAdam             fcont=fcont*fcont1
1352 cAdam           endif
1353 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1354 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1355 cga             do k=1,3
1356 cga               gg(k)=gg(k)*eps0ij
1357 cga             enddo
1358 cga             eps0ij=-evdwij*eps0ij
1359 C Uncomment for AL's type of SC correlation interactions.
1360 cadam           eps0ij=-evdwij
1361                 num_conti=num_conti+1
1362                 jcont(num_conti,i)=j
1363                 facont(num_conti,i)=fcont*eps0ij
1364                 fprimcont=eps0ij*fprimcont/rij
1365                 fcont=expon*fcont
1366 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1367 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1368 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1369 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1370                 gacont(1,num_conti,i)=-fprimcont*xj
1371                 gacont(2,num_conti,i)=-fprimcont*yj
1372                 gacont(3,num_conti,i)=-fprimcont*zj
1373 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1374 cd              write (iout,'(2i3,3f10.5)')
1375 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1376               endif
1377             endif
1378           enddo      ! j
1379         enddo        ! iint
1380 C Change 12/1/95
1381         num_cont(i)=num_conti
1382       enddo          ! i
1383       do i=1,nct
1384         do j=1,3
1385           gvdwc(j,i)=expon*gvdwc(j,i)
1386           gvdwx(j,i)=expon*gvdwx(j,i)
1387         enddo
1388       enddo
1389 C******************************************************************************
1390 C
1391 C                              N O T E !!!
1392 C
1393 C To save time, the factor of EXPON has been extracted from ALL components
1394 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1395 C use!
1396 C
1397 C******************************************************************************
1398       return
1399       end
1400 C-----------------------------------------------------------------------------
1401       subroutine eljk(evdw,evdw_p,evdw_m)
1402 C
1403 C This subroutine calculates the interaction energy of nonbonded side chains
1404 C assuming the LJK potential of interaction.
1405 C
1406       implicit real*8 (a-h,o-z)
1407       include 'DIMENSIONS'
1408       include 'COMMON.GEO'
1409       include 'COMMON.VAR'
1410       include 'COMMON.LOCAL'
1411       include 'COMMON.CHAIN'
1412       include 'COMMON.DERIV'
1413       include 'COMMON.INTERACT'
1414       include 'COMMON.IOUNITS'
1415       include 'COMMON.NAMES'
1416       dimension gg(3)
1417       logical scheck
1418 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1419       evdw=0.0D0
1420       do i=iatsc_s,iatsc_e
1421         itypi=itype(i)
1422         itypi1=itype(i+1)
1423         xi=c(1,nres+i)
1424         yi=c(2,nres+i)
1425         zi=c(3,nres+i)
1426 C
1427 C Calculate SC interaction energy.
1428 C
1429         do iint=1,nint_gr(i)
1430           do j=istart(i,iint),iend(i,iint)
1431             itypj=itype(j)
1432             xj=c(1,nres+j)-xi
1433             yj=c(2,nres+j)-yi
1434             zj=c(3,nres+j)-zi
1435             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1436             fac_augm=rrij**expon
1437             e_augm=augm(itypi,itypj)*fac_augm
1438             r_inv_ij=dsqrt(rrij)
1439             rij=1.0D0/r_inv_ij
1440             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1441             fac=r_shift_inv**expon
1442             e1=fac*fac*aa(itypi,itypj)
1443             e2=fac*bb(itypi,itypj)
1444             evdwij=e_augm+e1+e2
1445 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1446 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1447 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1448 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1449 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1450 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1451 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1452 #ifdef TSCSC
1453             if (bb(itypi,itypj).gt.0) then
1454                evdw_p=evdw_p+evdwij
1455             else
1456                evdw_m=evdw_m+evdwij
1457             endif
1458 #else
1459             evdw=evdw+evdwij
1460 #endif
1461 C
1462 C Calculate the components of the gradient in DC and X
1463 C
1464             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1465             gg(1)=xj*fac
1466             gg(2)=yj*fac
1467             gg(3)=zj*fac
1468 #ifdef TSCSC
1469             if (bb(itypi,itypj).gt.0.0d0) then
1470               do k=1,3
1471                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1472                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1473                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1474                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1475               enddo
1476             else
1477               do k=1,3
1478                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1479                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1480                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1481                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1482               enddo
1483             endif
1484 #else
1485             do k=1,3
1486               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1487               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1488               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1489               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1490             enddo
1491 #endif
1492 cgrad            do k=i,j-1
1493 cgrad              do l=1,3
1494 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1495 cgrad              enddo
1496 cgrad            enddo
1497           enddo      ! j
1498         enddo        ! iint
1499       enddo          ! i
1500       do i=1,nct
1501         do j=1,3
1502           gvdwc(j,i)=expon*gvdwc(j,i)
1503           gvdwx(j,i)=expon*gvdwx(j,i)
1504         enddo
1505       enddo
1506       return
1507       end
1508 C-----------------------------------------------------------------------------
1509       subroutine ebp(evdw,evdw_p,evdw_m)
1510 C
1511 C This subroutine calculates the interaction energy of nonbonded side chains
1512 C assuming the Berne-Pechukas potential of interaction.
1513 C
1514       implicit real*8 (a-h,o-z)
1515       include 'DIMENSIONS'
1516       include 'COMMON.GEO'
1517       include 'COMMON.VAR'
1518       include 'COMMON.LOCAL'
1519       include 'COMMON.CHAIN'
1520       include 'COMMON.DERIV'
1521       include 'COMMON.NAMES'
1522       include 'COMMON.INTERACT'
1523       include 'COMMON.IOUNITS'
1524       include 'COMMON.CALC'
1525       common /srutu/ icall
1526 c     double precision rrsave(maxdim)
1527       logical lprn
1528       evdw=0.0D0
1529 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1530       evdw=0.0D0
1531 c     if (icall.eq.0) then
1532 c       lprn=.true.
1533 c     else
1534         lprn=.false.
1535 c     endif
1536       ind=0
1537       do i=iatsc_s,iatsc_e
1538         itypi=itype(i)
1539         itypi1=itype(i+1)
1540         xi=c(1,nres+i)
1541         yi=c(2,nres+i)
1542         zi=c(3,nres+i)
1543         dxi=dc_norm(1,nres+i)
1544         dyi=dc_norm(2,nres+i)
1545         dzi=dc_norm(3,nres+i)
1546 c        dsci_inv=dsc_inv(itypi)
1547         dsci_inv=vbld_inv(i+nres)
1548 C
1549 C Calculate SC interaction energy.
1550 C
1551         do iint=1,nint_gr(i)
1552           do j=istart(i,iint),iend(i,iint)
1553             ind=ind+1
1554             itypj=itype(j)
1555 c            dscj_inv=dsc_inv(itypj)
1556             dscj_inv=vbld_inv(j+nres)
1557             chi1=chi(itypi,itypj)
1558             chi2=chi(itypj,itypi)
1559             chi12=chi1*chi2
1560             chip1=chip(itypi)
1561             chip2=chip(itypj)
1562             chip12=chip1*chip2
1563             alf1=alp(itypi)
1564             alf2=alp(itypj)
1565             alf12=0.5D0*(alf1+alf2)
1566 C For diagnostics only!!!
1567 c           chi1=0.0D0
1568 c           chi2=0.0D0
1569 c           chi12=0.0D0
1570 c           chip1=0.0D0
1571 c           chip2=0.0D0
1572 c           chip12=0.0D0
1573 c           alf1=0.0D0
1574 c           alf2=0.0D0
1575 c           alf12=0.0D0
1576             xj=c(1,nres+j)-xi
1577             yj=c(2,nres+j)-yi
1578             zj=c(3,nres+j)-zi
1579             dxj=dc_norm(1,nres+j)
1580             dyj=dc_norm(2,nres+j)
1581             dzj=dc_norm(3,nres+j)
1582             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1583 cd          if (icall.eq.0) then
1584 cd            rrsave(ind)=rrij
1585 cd          else
1586 cd            rrij=rrsave(ind)
1587 cd          endif
1588             rij=dsqrt(rrij)
1589 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1590             call sc_angular
1591 C Calculate whole angle-dependent part of epsilon and contributions
1592 C to its derivatives
1593             fac=(rrij*sigsq)**expon2
1594             e1=fac*fac*aa(itypi,itypj)
1595             e2=fac*bb(itypi,itypj)
1596             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1597             eps2der=evdwij*eps3rt
1598             eps3der=evdwij*eps2rt
1599             evdwij=evdwij*eps2rt*eps3rt
1600 #ifdef TSCSC
1601             if (bb(itypi,itypj).gt.0) then
1602                evdw_p=evdw_p+evdwij
1603             else
1604                evdw_m=evdw_m+evdwij
1605             endif
1606 #else
1607             evdw=evdw+evdwij
1608 #endif
1609             if (lprn) then
1610             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1611             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1612 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1613 cd     &        restyp(itypi),i,restyp(itypj),j,
1614 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1615 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1616 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1617 cd     &        evdwij
1618             endif
1619 C Calculate gradient components.
1620             e1=e1*eps1*eps2rt**2*eps3rt**2
1621             fac=-expon*(e1+evdwij)
1622             sigder=fac/sigsq
1623             fac=rrij*fac
1624 C Calculate radial part of the gradient
1625             gg(1)=xj*fac
1626             gg(2)=yj*fac
1627             gg(3)=zj*fac
1628 C Calculate the angular part of the gradient and sum add the contributions
1629 C to the appropriate components of the Cartesian gradient.
1630 #ifdef TSCSC
1631             if (bb(itypi,itypj).gt.0) then
1632                call sc_grad
1633             else
1634                call sc_grad_T
1635             endif
1636 #else
1637             call sc_grad
1638 #endif
1639           enddo      ! j
1640         enddo        ! iint
1641       enddo          ! i
1642 c     stop
1643       return
1644       end
1645 C-----------------------------------------------------------------------------
1646       subroutine egb(evdw,evdw_p,evdw_m)
1647 C
1648 C This subroutine calculates the interaction energy of nonbonded side chains
1649 C assuming the Gay-Berne potential of interaction.
1650 C
1651       implicit real*8 (a-h,o-z)
1652       include 'DIMENSIONS'
1653       include 'COMMON.GEO'
1654       include 'COMMON.VAR'
1655       include 'COMMON.LOCAL'
1656       include 'COMMON.CHAIN'
1657       include 'COMMON.DERIV'
1658       include 'COMMON.NAMES'
1659       include 'COMMON.INTERACT'
1660       include 'COMMON.IOUNITS'
1661       include 'COMMON.CALC'
1662       include 'COMMON.CONTROL'
1663       include 'COMMON.SBRIDGE'
1664       logical lprn
1665       evdw=0.0D0
1666 ccccc      energy_dec=.false.
1667 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1668       evdw=0.0D0
1669       evdw_p=0.0D0
1670       evdw_m=0.0D0
1671       lprn=.false.
1672 c     if (icall.eq.0) lprn=.false.
1673       ind=0
1674       do i=iatsc_s,iatsc_e
1675         itypi=itype(i)
1676         itypi1=itype(i+1)
1677         xi=c(1,nres+i)
1678         yi=c(2,nres+i)
1679         zi=c(3,nres+i)
1680         dxi=dc_norm(1,nres+i)
1681         dyi=dc_norm(2,nres+i)
1682         dzi=dc_norm(3,nres+i)
1683 c        dsci_inv=dsc_inv(itypi)
1684         dsci_inv=vbld_inv(i+nres)
1685 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1686 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1687 C
1688 C Calculate SC interaction energy.
1689 C
1690         do iint=1,nint_gr(i)
1691           do j=istart(i,iint),iend(i,iint)
1692             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1693               call dyn_ssbond_ene(i,j,evdwij)
1694               evdw=evdw+evdwij
1695               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1696      &                        'evdw',i,j,evdwij,' ss'
1697             ELSE
1698             ind=ind+1
1699             itypj=itype(j)
1700 c            dscj_inv=dsc_inv(itypj)
1701             dscj_inv=vbld_inv(j+nres)
1702 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1703 c     &       1.0d0/vbld(j+nres)
1704 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1705             sig0ij=sigma(itypi,itypj)
1706             chi1=chi(itypi,itypj)
1707             chi2=chi(itypj,itypi)
1708             chi12=chi1*chi2
1709             chip1=chip(itypi)
1710             chip2=chip(itypj)
1711             chip12=chip1*chip2
1712             alf1=alp(itypi)
1713             alf2=alp(itypj)
1714             alf12=0.5D0*(alf1+alf2)
1715 C For diagnostics only!!!
1716 c           chi1=0.0D0
1717 c           chi2=0.0D0
1718 c           chi12=0.0D0
1719 c           chip1=0.0D0
1720 c           chip2=0.0D0
1721 c           chip12=0.0D0
1722 c           alf1=0.0D0
1723 c           alf2=0.0D0
1724 c           alf12=0.0D0
1725             xj=c(1,nres+j)-xi
1726             yj=c(2,nres+j)-yi
1727             zj=c(3,nres+j)-zi
1728             dxj=dc_norm(1,nres+j)
1729             dyj=dc_norm(2,nres+j)
1730             dzj=dc_norm(3,nres+j)
1731 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1732 c            write (iout,*) "j",j," dc_norm",
1733 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1734             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1735             rij=dsqrt(rrij)
1736 C Calculate angle-dependent terms of energy and contributions to their
1737 C derivatives.
1738             call sc_angular
1739             sigsq=1.0D0/sigsq
1740             sig=sig0ij*dsqrt(sigsq)
1741             rij_shift=1.0D0/rij-sig+sig0ij
1742 c for diagnostics; uncomment
1743 c            rij_shift=1.2*sig0ij
1744 C I hate to put IF's in the loops, but here don't have another choice!!!!
1745             if (rij_shift.le.0.0D0) then
1746               evdw=1.0D20
1747 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1748 cd     &        restyp(itypi),i,restyp(itypj),j,
1749 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1750               return
1751             endif
1752             sigder=-sig*sigsq
1753 c---------------------------------------------------------------
1754             rij_shift=1.0D0/rij_shift
1755             fac=rij_shift**expon
1756             e1=fac*fac*aa(itypi,itypj)
1757             e2=fac*bb(itypi,itypj)
1758             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1759             eps2der=evdwij*eps3rt
1760             eps3der=evdwij*eps2rt
1761 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1762 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1763             evdwij=evdwij*eps2rt*eps3rt
1764 #ifdef TSCSC
1765             if (bb(itypi,itypj).gt.0) then
1766                evdw_p=evdw_p+evdwij
1767             else
1768                evdw_m=evdw_m+evdwij
1769             endif
1770 #else
1771             evdw=evdw+evdwij
1772 #endif
1773             if (lprn) then
1774             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1775             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1776             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1777      &        restyp(itypi),i,restyp(itypj),j,
1778      &        epsi,sigm,chi1,chi2,chip1,chip2,
1779      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1780      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1781      &        evdwij
1782             endif
1783
1784             if (energy_dec) then
1785               write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
1786               call flush(iout)
1787             endif
1788 C Calculate gradient components.
1789             e1=e1*eps1*eps2rt**2*eps3rt**2
1790             fac=-expon*(e1+evdwij)*rij_shift
1791             sigder=fac*sigder
1792             fac=rij*fac
1793 c            fac=0.0d0
1794 C Calculate the radial part of the gradient
1795             gg(1)=xj*fac
1796             gg(2)=yj*fac
1797             gg(3)=zj*fac
1798 C Calculate angular part of the gradient.
1799 #ifdef TSCSC
1800             if (bb(itypi,itypj).gt.0) then
1801                call sc_grad
1802             else
1803                call sc_grad_T
1804             endif
1805 #else
1806             call sc_grad
1807 #endif
1808             ENDIF    ! dyn_ss
1809           enddo      ! j
1810         enddo        ! iint
1811       enddo          ! i
1812 c      write (iout,*) "Number of loop steps in EGB:",ind
1813 cccc      energy_dec=.false.
1814       return
1815       end
1816 C-----------------------------------------------------------------------------
1817       subroutine egbv(evdw,evdw_p,evdw_m)
1818 C
1819 C This subroutine calculates the interaction energy of nonbonded side chains
1820 C assuming the Gay-Berne-Vorobjev potential of interaction.
1821 C
1822       implicit real*8 (a-h,o-z)
1823       include 'DIMENSIONS'
1824       include 'COMMON.GEO'
1825       include 'COMMON.VAR'
1826       include 'COMMON.LOCAL'
1827       include 'COMMON.CHAIN'
1828       include 'COMMON.DERIV'
1829       include 'COMMON.NAMES'
1830       include 'COMMON.INTERACT'
1831       include 'COMMON.IOUNITS'
1832       include 'COMMON.CALC'
1833       common /srutu/ icall
1834       logical lprn
1835       evdw=0.0D0
1836 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1837       evdw=0.0D0
1838       lprn=.false.
1839 c     if (icall.eq.0) lprn=.true.
1840       ind=0
1841       do i=iatsc_s,iatsc_e
1842         itypi=itype(i)
1843         itypi1=itype(i+1)
1844         xi=c(1,nres+i)
1845         yi=c(2,nres+i)
1846         zi=c(3,nres+i)
1847         dxi=dc_norm(1,nres+i)
1848         dyi=dc_norm(2,nres+i)
1849         dzi=dc_norm(3,nres+i)
1850 c        dsci_inv=dsc_inv(itypi)
1851         dsci_inv=vbld_inv(i+nres)
1852 C
1853 C Calculate SC interaction energy.
1854 C
1855         do iint=1,nint_gr(i)
1856           do j=istart(i,iint),iend(i,iint)
1857             ind=ind+1
1858             itypj=itype(j)
1859 c            dscj_inv=dsc_inv(itypj)
1860             dscj_inv=vbld_inv(j+nres)
1861             sig0ij=sigma(itypi,itypj)
1862             r0ij=r0(itypi,itypj)
1863             chi1=chi(itypi,itypj)
1864             chi2=chi(itypj,itypi)
1865             chi12=chi1*chi2
1866             chip1=chip(itypi)
1867             chip2=chip(itypj)
1868             chip12=chip1*chip2
1869             alf1=alp(itypi)
1870             alf2=alp(itypj)
1871             alf12=0.5D0*(alf1+alf2)
1872 C For diagnostics only!!!
1873 c           chi1=0.0D0
1874 c           chi2=0.0D0
1875 c           chi12=0.0D0
1876 c           chip1=0.0D0
1877 c           chip2=0.0D0
1878 c           chip12=0.0D0
1879 c           alf1=0.0D0
1880 c           alf2=0.0D0
1881 c           alf12=0.0D0
1882             xj=c(1,nres+j)-xi
1883             yj=c(2,nres+j)-yi
1884             zj=c(3,nres+j)-zi
1885             dxj=dc_norm(1,nres+j)
1886             dyj=dc_norm(2,nres+j)
1887             dzj=dc_norm(3,nres+j)
1888             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1889             rij=dsqrt(rrij)
1890 C Calculate angle-dependent terms of energy and contributions to their
1891 C derivatives.
1892             call sc_angular
1893             sigsq=1.0D0/sigsq
1894             sig=sig0ij*dsqrt(sigsq)
1895             rij_shift=1.0D0/rij-sig+r0ij
1896 C I hate to put IF's in the loops, but here don't have another choice!!!!
1897             if (rij_shift.le.0.0D0) then
1898               evdw=1.0D20
1899               return
1900             endif
1901             sigder=-sig*sigsq
1902 c---------------------------------------------------------------
1903             rij_shift=1.0D0/rij_shift
1904             fac=rij_shift**expon
1905             e1=fac*fac*aa(itypi,itypj)
1906             e2=fac*bb(itypi,itypj)
1907             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1908             eps2der=evdwij*eps3rt
1909             eps3der=evdwij*eps2rt
1910             fac_augm=rrij**expon
1911             e_augm=augm(itypi,itypj)*fac_augm
1912             evdwij=evdwij*eps2rt*eps3rt
1913 #ifdef TSCSC
1914             if (bb(itypi,itypj).gt.0) then
1915                evdw_p=evdw_p+evdwij+e_augm
1916             else
1917                evdw_m=evdw_m+evdwij+e_augm
1918             endif
1919 #else
1920             evdw=evdw+evdwij+e_augm
1921 #endif
1922             if (lprn) then
1923             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1924             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1925             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1926      &        restyp(itypi),i,restyp(itypj),j,
1927      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1928      &        chi1,chi2,chip1,chip2,
1929      &        eps1,eps2rt**2,eps3rt**2,
1930      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1931      &        evdwij+e_augm
1932             endif
1933 C Calculate gradient components.
1934             e1=e1*eps1*eps2rt**2*eps3rt**2
1935             fac=-expon*(e1+evdwij)*rij_shift
1936             sigder=fac*sigder
1937             fac=rij*fac-2*expon*rrij*e_augm
1938 C Calculate the radial part of the gradient
1939             gg(1)=xj*fac
1940             gg(2)=yj*fac
1941             gg(3)=zj*fac
1942 C Calculate angular part of the gradient.
1943 #ifdef TSCSC
1944             if (bb(itypi,itypj).gt.0) then
1945                call sc_grad
1946             else
1947                call sc_grad_T
1948             endif
1949 #else
1950             call sc_grad
1951 #endif
1952           enddo      ! j
1953         enddo        ! iint
1954       enddo          ! i
1955       end
1956 C-----------------------------------------------------------------------------
1957       subroutine sc_angular
1958 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1959 C om12. Called by ebp, egb, and egbv.
1960       implicit none
1961       include 'COMMON.CALC'
1962       include 'COMMON.IOUNITS'
1963       erij(1)=xj*rij
1964       erij(2)=yj*rij
1965       erij(3)=zj*rij
1966       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1967       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1968       om12=dxi*dxj+dyi*dyj+dzi*dzj
1969       chiom12=chi12*om12
1970 C Calculate eps1(om12) and its derivative in om12
1971       faceps1=1.0D0-om12*chiom12
1972       faceps1_inv=1.0D0/faceps1
1973       eps1=dsqrt(faceps1_inv)
1974 C Following variable is eps1*deps1/dom12
1975       eps1_om12=faceps1_inv*chiom12
1976 c diagnostics only
1977 c      faceps1_inv=om12
1978 c      eps1=om12
1979 c      eps1_om12=1.0d0
1980 c      write (iout,*) "om12",om12," eps1",eps1
1981 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1982 C and om12.
1983       om1om2=om1*om2
1984       chiom1=chi1*om1
1985       chiom2=chi2*om2
1986       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1987       sigsq=1.0D0-facsig*faceps1_inv
1988       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1989       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1990       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1991 c diagnostics only
1992 c      sigsq=1.0d0
1993 c      sigsq_om1=0.0d0
1994 c      sigsq_om2=0.0d0
1995 c      sigsq_om12=0.0d0
1996 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1997 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1998 c     &    " eps1",eps1
1999 C Calculate eps2 and its derivatives in om1, om2, and om12.
2000       chipom1=chip1*om1
2001       chipom2=chip2*om2
2002       chipom12=chip12*om12
2003       facp=1.0D0-om12*chipom12
2004       facp_inv=1.0D0/facp
2005       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2006 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2007 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2008 C Following variable is the square root of eps2
2009       eps2rt=1.0D0-facp1*facp_inv
2010 C Following three variables are the derivatives of the square root of eps
2011 C in om1, om2, and om12.
2012       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2013       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2014       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2015 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2016       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2017 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2018 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2019 c     &  " eps2rt_om12",eps2rt_om12
2020 C Calculate whole angle-dependent part of epsilon and contributions
2021 C to its derivatives
2022       return
2023       end
2024
2025 C----------------------------------------------------------------------------
2026       subroutine sc_grad_T
2027       implicit real*8 (a-h,o-z)
2028       include 'DIMENSIONS'
2029       include 'COMMON.CHAIN'
2030       include 'COMMON.DERIV'
2031       include 'COMMON.CALC'
2032       include 'COMMON.IOUNITS'
2033       double precision dcosom1(3),dcosom2(3)
2034       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2035       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2036       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2037      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2038 c diagnostics only
2039 c      eom1=0.0d0
2040 c      eom2=0.0d0
2041 c      eom12=evdwij*eps1_om12
2042 c end diagnostics
2043 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2044 c     &  " sigder",sigder
2045 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2046 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2047       do k=1,3
2048         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2049         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2050       enddo
2051       do k=1,3
2052         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2053       enddo
2054 c      write (iout,*) "gg",(gg(k),k=1,3)
2055       do k=1,3
2056         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
2057      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2058      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2059         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
2060      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2061      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2062 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2063 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2064 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2065 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2066       enddo
2067 C
2068 C Calculate the components of the gradient in DC and X
2069 C
2070 cgrad      do k=i,j-1
2071 cgrad        do l=1,3
2072 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2073 cgrad        enddo
2074 cgrad      enddo
2075       do l=1,3
2076         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
2077         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
2078       enddo
2079       return
2080       end
2081
2082 C----------------------------------------------------------------------------
2083       subroutine sc_grad
2084       implicit real*8 (a-h,o-z)
2085       include 'DIMENSIONS'
2086       include 'COMMON.CHAIN'
2087       include 'COMMON.DERIV'
2088       include 'COMMON.CALC'
2089       include 'COMMON.IOUNITS'
2090       double precision dcosom1(3),dcosom2(3)
2091       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2092       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2093       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2094      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2095 c diagnostics only
2096 c      eom1=0.0d0
2097 c      eom2=0.0d0
2098 c      eom12=evdwij*eps1_om12
2099 c end diagnostics
2100 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2101 c     &  " sigder",sigder
2102 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2103 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2104       do k=1,3
2105         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2106         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2107       enddo
2108       do k=1,3
2109         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2110       enddo
2111 c      write (iout,*) "gg",(gg(k),k=1,3)
2112       do k=1,3
2113         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2114      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2115      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2116         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2117      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2118      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2119 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2120 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2121 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2122 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2123       enddo
2124 C
2125 C Calculate the components of the gradient in DC and X
2126 C
2127 cgrad      do k=i,j-1
2128 cgrad        do l=1,3
2129 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2130 cgrad        enddo
2131 cgrad      enddo
2132       do l=1,3
2133         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2134         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2135       enddo
2136       return
2137       end
2138 C-----------------------------------------------------------------------
2139       subroutine e_softsphere(evdw)
2140 C
2141 C This subroutine calculates the interaction energy of nonbonded side chains
2142 C assuming the LJ potential of interaction.
2143 C
2144       implicit real*8 (a-h,o-z)
2145       include 'DIMENSIONS'
2146       parameter (accur=1.0d-10)
2147       include 'COMMON.GEO'
2148       include 'COMMON.VAR'
2149       include 'COMMON.LOCAL'
2150       include 'COMMON.CHAIN'
2151       include 'COMMON.DERIV'
2152       include 'COMMON.INTERACT'
2153       include 'COMMON.TORSION'
2154       include 'COMMON.SBRIDGE'
2155       include 'COMMON.NAMES'
2156       include 'COMMON.IOUNITS'
2157       include 'COMMON.CONTACTS'
2158       dimension gg(3)
2159 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2160       evdw=0.0D0
2161       do i=iatsc_s,iatsc_e
2162         itypi=itype(i)
2163         itypi1=itype(i+1)
2164         xi=c(1,nres+i)
2165         yi=c(2,nres+i)
2166         zi=c(3,nres+i)
2167 C
2168 C Calculate SC interaction energy.
2169 C
2170         do iint=1,nint_gr(i)
2171 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2172 cd   &                  'iend=',iend(i,iint)
2173           do j=istart(i,iint),iend(i,iint)
2174             itypj=itype(j)
2175             xj=c(1,nres+j)-xi
2176             yj=c(2,nres+j)-yi
2177             zj=c(3,nres+j)-zi
2178             rij=xj*xj+yj*yj+zj*zj
2179 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2180             r0ij=r0(itypi,itypj)
2181             r0ijsq=r0ij*r0ij
2182 c            print *,i,j,r0ij,dsqrt(rij)
2183             if (rij.lt.r0ijsq) then
2184               evdwij=0.25d0*(rij-r0ijsq)**2
2185               fac=rij-r0ijsq
2186             else
2187               evdwij=0.0d0
2188               fac=0.0d0
2189             endif
2190             evdw=evdw+evdwij
2191 C
2192 C Calculate the components of the gradient in DC and X
2193 C
2194             gg(1)=xj*fac
2195             gg(2)=yj*fac
2196             gg(3)=zj*fac
2197             do k=1,3
2198               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2199               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2200               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2201               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2202             enddo
2203 cgrad            do k=i,j-1
2204 cgrad              do l=1,3
2205 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2206 cgrad              enddo
2207 cgrad            enddo
2208           enddo ! j
2209         enddo ! iint
2210       enddo ! i
2211       return
2212       end
2213 C--------------------------------------------------------------------------
2214       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2215      &              eello_turn4)
2216 C
2217 C Soft-sphere potential of p-p interaction
2218 C
2219       implicit real*8 (a-h,o-z)
2220       include 'DIMENSIONS'
2221       include 'COMMON.CONTROL'
2222       include 'COMMON.IOUNITS'
2223       include 'COMMON.GEO'
2224       include 'COMMON.VAR'
2225       include 'COMMON.LOCAL'
2226       include 'COMMON.CHAIN'
2227       include 'COMMON.DERIV'
2228       include 'COMMON.INTERACT'
2229       include 'COMMON.CONTACTS'
2230       include 'COMMON.TORSION'
2231       include 'COMMON.VECTORS'
2232       include 'COMMON.FFIELD'
2233       dimension ggg(3)
2234 cd      write(iout,*) 'In EELEC_soft_sphere'
2235       ees=0.0D0
2236       evdw1=0.0D0
2237       eel_loc=0.0d0
2238       eello_turn3=0.0d0
2239       eello_turn4=0.0d0
2240       ind=0
2241       do i=iatel_s,iatel_e
2242         dxi=dc(1,i)
2243         dyi=dc(2,i)
2244         dzi=dc(3,i)
2245         xmedi=c(1,i)+0.5d0*dxi
2246         ymedi=c(2,i)+0.5d0*dyi
2247         zmedi=c(3,i)+0.5d0*dzi
2248         num_conti=0
2249 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2250         do j=ielstart(i),ielend(i)
2251           ind=ind+1
2252           iteli=itel(i)
2253           itelj=itel(j)
2254           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2255           r0ij=rpp(iteli,itelj)
2256           r0ijsq=r0ij*r0ij
2257           dxj=dc(1,j)
2258           dyj=dc(2,j)
2259           dzj=dc(3,j)
2260           xj=c(1,j)+0.5D0*dxj-xmedi
2261           yj=c(2,j)+0.5D0*dyj-ymedi
2262           zj=c(3,j)+0.5D0*dzj-zmedi
2263           rij=xj*xj+yj*yj+zj*zj
2264           if (rij.lt.r0ijsq) then
2265             evdw1ij=0.25d0*(rij-r0ijsq)**2
2266             fac=rij-r0ijsq
2267           else
2268             evdw1ij=0.0d0
2269             fac=0.0d0
2270           endif
2271           evdw1=evdw1+evdw1ij
2272 C
2273 C Calculate contributions to the Cartesian gradient.
2274 C
2275           ggg(1)=fac*xj
2276           ggg(2)=fac*yj
2277           ggg(3)=fac*zj
2278           do k=1,3
2279             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2280             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2281           enddo
2282 *
2283 * Loop over residues i+1 thru j-1.
2284 *
2285 cgrad          do k=i+1,j-1
2286 cgrad            do l=1,3
2287 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2288 cgrad            enddo
2289 cgrad          enddo
2290         enddo ! j
2291       enddo   ! i
2292 cgrad      do i=nnt,nct-1
2293 cgrad        do k=1,3
2294 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2295 cgrad        enddo
2296 cgrad        do j=i+1,nct-1
2297 cgrad          do k=1,3
2298 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2299 cgrad          enddo
2300 cgrad        enddo
2301 cgrad      enddo
2302       return
2303       end
2304 c------------------------------------------------------------------------------
2305       subroutine vec_and_deriv
2306       implicit real*8 (a-h,o-z)
2307       include 'DIMENSIONS'
2308 #ifdef MPI
2309       include 'mpif.h'
2310 #endif
2311       include 'COMMON.IOUNITS'
2312       include 'COMMON.GEO'
2313       include 'COMMON.VAR'
2314       include 'COMMON.LOCAL'
2315       include 'COMMON.CHAIN'
2316       include 'COMMON.VECTORS'
2317       include 'COMMON.SETUP'
2318       include 'COMMON.TIME1'
2319       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2320 C Compute the local reference systems. For reference system (i), the
2321 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2322 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2323 #ifdef PARVEC
2324       do i=ivec_start,ivec_end
2325 #else
2326       do i=1,nres-1
2327 #endif
2328           if (i.eq.nres-1) then
2329 C Case of the last full residue
2330 C Compute the Z-axis
2331             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2332             costh=dcos(pi-theta(nres))
2333             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2334             do k=1,3
2335               uz(k,i)=fac*uz(k,i)
2336             enddo
2337 C Compute the derivatives of uz
2338             uzder(1,1,1)= 0.0d0
2339             uzder(2,1,1)=-dc_norm(3,i-1)
2340             uzder(3,1,1)= dc_norm(2,i-1)
2341             uzder(1,2,1)= dc_norm(3,i-1)
2342             uzder(2,2,1)= 0.0d0
2343             uzder(3,2,1)=-dc_norm(1,i-1)
2344             uzder(1,3,1)=-dc_norm(2,i-1)
2345             uzder(2,3,1)= dc_norm(1,i-1)
2346             uzder(3,3,1)= 0.0d0
2347             uzder(1,1,2)= 0.0d0
2348             uzder(2,1,2)= dc_norm(3,i)
2349             uzder(3,1,2)=-dc_norm(2,i)
2350             uzder(1,2,2)=-dc_norm(3,i)
2351             uzder(2,2,2)= 0.0d0
2352             uzder(3,2,2)= dc_norm(1,i)
2353             uzder(1,3,2)= dc_norm(2,i)
2354             uzder(2,3,2)=-dc_norm(1,i)
2355             uzder(3,3,2)= 0.0d0
2356 C Compute the Y-axis
2357             facy=fac
2358             do k=1,3
2359               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2360             enddo
2361 C Compute the derivatives of uy
2362             do j=1,3
2363               do k=1,3
2364                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2365      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2366                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2367               enddo
2368               uyder(j,j,1)=uyder(j,j,1)-costh
2369               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2370             enddo
2371             do j=1,2
2372               do k=1,3
2373                 do l=1,3
2374                   uygrad(l,k,j,i)=uyder(l,k,j)
2375                   uzgrad(l,k,j,i)=uzder(l,k,j)
2376                 enddo
2377               enddo
2378             enddo
2379             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2380             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2381             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2382             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2383           else
2384 C Other residues
2385 C Compute the Z-axis
2386             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2387             costh=dcos(pi-theta(i+2))
2388             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2389             do k=1,3
2390               uz(k,i)=fac*uz(k,i)
2391             enddo
2392 C Compute the derivatives of uz
2393             uzder(1,1,1)= 0.0d0
2394             uzder(2,1,1)=-dc_norm(3,i+1)
2395             uzder(3,1,1)= dc_norm(2,i+1)
2396             uzder(1,2,1)= dc_norm(3,i+1)
2397             uzder(2,2,1)= 0.0d0
2398             uzder(3,2,1)=-dc_norm(1,i+1)
2399             uzder(1,3,1)=-dc_norm(2,i+1)
2400             uzder(2,3,1)= dc_norm(1,i+1)
2401             uzder(3,3,1)= 0.0d0
2402             uzder(1,1,2)= 0.0d0
2403             uzder(2,1,2)= dc_norm(3,i)
2404             uzder(3,1,2)=-dc_norm(2,i)
2405             uzder(1,2,2)=-dc_norm(3,i)
2406             uzder(2,2,2)= 0.0d0
2407             uzder(3,2,2)= dc_norm(1,i)
2408             uzder(1,3,2)= dc_norm(2,i)
2409             uzder(2,3,2)=-dc_norm(1,i)
2410             uzder(3,3,2)= 0.0d0
2411 C Compute the Y-axis
2412             facy=fac
2413             do k=1,3
2414               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2415             enddo
2416 C Compute the derivatives of uy
2417             do j=1,3
2418               do k=1,3
2419                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2420      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2421                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2422               enddo
2423               uyder(j,j,1)=uyder(j,j,1)-costh
2424               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2425             enddo
2426             do j=1,2
2427               do k=1,3
2428                 do l=1,3
2429                   uygrad(l,k,j,i)=uyder(l,k,j)
2430                   uzgrad(l,k,j,i)=uzder(l,k,j)
2431                 enddo
2432               enddo
2433             enddo
2434             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2435             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2436             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2437             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2438           endif
2439       enddo
2440       do i=1,nres-1
2441         vbld_inv_temp(1)=vbld_inv(i+1)
2442         if (i.lt.nres-1) then
2443           vbld_inv_temp(2)=vbld_inv(i+2)
2444           else
2445           vbld_inv_temp(2)=vbld_inv(i)
2446           endif
2447         do j=1,2
2448           do k=1,3
2449             do l=1,3
2450               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2451               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2452             enddo
2453           enddo
2454         enddo
2455       enddo
2456 #if defined(PARVEC) && defined(MPI)
2457       if (nfgtasks1.gt.1) then
2458         time00=MPI_Wtime()
2459 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2460 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2461 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2462         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2463      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2464      &   FG_COMM1,IERR)
2465         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2466      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2467      &   FG_COMM1,IERR)
2468         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2469      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2470      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2471         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2472      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2473      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2474         time_gather=time_gather+MPI_Wtime()-time00
2475       endif
2476 c      if (fg_rank.eq.0) then
2477 c        write (iout,*) "Arrays UY and UZ"
2478 c        do i=1,nres-1
2479 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2480 c     &     (uz(k,i),k=1,3)
2481 c        enddo
2482 c      endif
2483 #endif
2484       return
2485       end
2486 C-----------------------------------------------------------------------------
2487       subroutine check_vecgrad
2488       implicit real*8 (a-h,o-z)
2489       include 'DIMENSIONS'
2490       include 'COMMON.IOUNITS'
2491       include 'COMMON.GEO'
2492       include 'COMMON.VAR'
2493       include 'COMMON.LOCAL'
2494       include 'COMMON.CHAIN'
2495       include 'COMMON.VECTORS'
2496       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2497       dimension uyt(3,maxres),uzt(3,maxres)
2498       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2499       double precision delta /1.0d-7/
2500       call vec_and_deriv
2501 cd      do i=1,nres
2502 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2503 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2504 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2505 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2506 cd     &     (dc_norm(if90,i),if90=1,3)
2507 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2508 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2509 cd          write(iout,'(a)')
2510 cd      enddo
2511       do i=1,nres
2512         do j=1,2
2513           do k=1,3
2514             do l=1,3
2515               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2516               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2517             enddo
2518           enddo
2519         enddo
2520       enddo
2521       call vec_and_deriv
2522       do i=1,nres
2523         do j=1,3
2524           uyt(j,i)=uy(j,i)
2525           uzt(j,i)=uz(j,i)
2526         enddo
2527       enddo
2528       do i=1,nres
2529 cd        write (iout,*) 'i=',i
2530         do k=1,3
2531           erij(k)=dc_norm(k,i)
2532         enddo
2533         do j=1,3
2534           do k=1,3
2535             dc_norm(k,i)=erij(k)
2536           enddo
2537           dc_norm(j,i)=dc_norm(j,i)+delta
2538 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2539 c          do k=1,3
2540 c            dc_norm(k,i)=dc_norm(k,i)/fac
2541 c          enddo
2542 c          write (iout,*) (dc_norm(k,i),k=1,3)
2543 c          write (iout,*) (erij(k),k=1,3)
2544           call vec_and_deriv
2545           do k=1,3
2546             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2547             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2548             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2549             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2550           enddo
2551 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2552 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2553 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2554         enddo
2555         do k=1,3
2556           dc_norm(k,i)=erij(k)
2557         enddo
2558 cd        do k=1,3
2559 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2560 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2561 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2562 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2563 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2564 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2565 cd          write (iout,'(a)')
2566 cd        enddo
2567       enddo
2568       return
2569       end
2570 C--------------------------------------------------------------------------
2571       subroutine set_matrices
2572       implicit real*8 (a-h,o-z)
2573       include 'DIMENSIONS'
2574 #ifdef MPI
2575       include "mpif.h"
2576       include "COMMON.SETUP"
2577       integer IERR
2578       integer status(MPI_STATUS_SIZE)
2579 #endif
2580       include 'COMMON.IOUNITS'
2581       include 'COMMON.GEO'
2582       include 'COMMON.VAR'
2583       include 'COMMON.LOCAL'
2584       include 'COMMON.CHAIN'
2585       include 'COMMON.DERIV'
2586       include 'COMMON.INTERACT'
2587       include 'COMMON.CONTACTS'
2588       include 'COMMON.TORSION'
2589       include 'COMMON.VECTORS'
2590       include 'COMMON.FFIELD'
2591       double precision auxvec(2),auxmat(2,2)
2592 C
2593 C Compute the virtual-bond-torsional-angle dependent quantities needed
2594 C to calculate the el-loc multibody terms of various order.
2595 C
2596 #ifdef PARMAT
2597       do i=ivec_start+2,ivec_end+2
2598 #else
2599       do i=3,nres+1
2600 #endif
2601         if (i .lt. nres+1) then
2602           sin1=dsin(phi(i))
2603           cos1=dcos(phi(i))
2604           sintab(i-2)=sin1
2605           costab(i-2)=cos1
2606           obrot(1,i-2)=cos1
2607           obrot(2,i-2)=sin1
2608           sin2=dsin(2*phi(i))
2609           cos2=dcos(2*phi(i))
2610           sintab2(i-2)=sin2
2611           costab2(i-2)=cos2
2612           obrot2(1,i-2)=cos2
2613           obrot2(2,i-2)=sin2
2614           Ug(1,1,i-2)=-cos1
2615           Ug(1,2,i-2)=-sin1
2616           Ug(2,1,i-2)=-sin1
2617           Ug(2,2,i-2)= cos1
2618           Ug2(1,1,i-2)=-cos2
2619           Ug2(1,2,i-2)=-sin2
2620           Ug2(2,1,i-2)=-sin2
2621           Ug2(2,2,i-2)= cos2
2622         else
2623           costab(i-2)=1.0d0
2624           sintab(i-2)=0.0d0
2625           obrot(1,i-2)=1.0d0
2626           obrot(2,i-2)=0.0d0
2627           obrot2(1,i-2)=0.0d0
2628           obrot2(2,i-2)=0.0d0
2629           Ug(1,1,i-2)=1.0d0
2630           Ug(1,2,i-2)=0.0d0
2631           Ug(2,1,i-2)=0.0d0
2632           Ug(2,2,i-2)=1.0d0
2633           Ug2(1,1,i-2)=0.0d0
2634           Ug2(1,2,i-2)=0.0d0
2635           Ug2(2,1,i-2)=0.0d0
2636           Ug2(2,2,i-2)=0.0d0
2637         endif
2638         if (i .gt. 3 .and. i .lt. nres+1) then
2639           obrot_der(1,i-2)=-sin1
2640           obrot_der(2,i-2)= cos1
2641           Ugder(1,1,i-2)= sin1
2642           Ugder(1,2,i-2)=-cos1
2643           Ugder(2,1,i-2)=-cos1
2644           Ugder(2,2,i-2)=-sin1
2645           dwacos2=cos2+cos2
2646           dwasin2=sin2+sin2
2647           obrot2_der(1,i-2)=-dwasin2
2648           obrot2_der(2,i-2)= dwacos2
2649           Ug2der(1,1,i-2)= dwasin2
2650           Ug2der(1,2,i-2)=-dwacos2
2651           Ug2der(2,1,i-2)=-dwacos2
2652           Ug2der(2,2,i-2)=-dwasin2
2653         else
2654           obrot_der(1,i-2)=0.0d0
2655           obrot_der(2,i-2)=0.0d0
2656           Ugder(1,1,i-2)=0.0d0
2657           Ugder(1,2,i-2)=0.0d0
2658           Ugder(2,1,i-2)=0.0d0
2659           Ugder(2,2,i-2)=0.0d0
2660           obrot2_der(1,i-2)=0.0d0
2661           obrot2_der(2,i-2)=0.0d0
2662           Ug2der(1,1,i-2)=0.0d0
2663           Ug2der(1,2,i-2)=0.0d0
2664           Ug2der(2,1,i-2)=0.0d0
2665           Ug2der(2,2,i-2)=0.0d0
2666         endif
2667 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2668         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2669           iti = itortyp(itype(i-2))
2670         else
2671           iti=ntortyp+1
2672         endif
2673 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2674         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2675           iti1 = itortyp(itype(i-1))
2676         else
2677           iti1=ntortyp+1
2678         endif
2679 cd        write (iout,*) '*******i',i,' iti1',iti
2680 cd        write (iout,*) 'b1',b1(:,iti)
2681 cd        write (iout,*) 'b2',b2(:,iti)
2682 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2683 c        if (i .gt. iatel_s+2) then
2684         if (i .gt. nnt+2) then
2685           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2686           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2687           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2688      &    then
2689           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2690           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2691           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2692           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2693           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2694           endif
2695         else
2696           do k=1,2
2697             Ub2(k,i-2)=0.0d0
2698             Ctobr(k,i-2)=0.0d0
2699             Dtobr2(k,i-2)=0.0d0
2700             do l=1,2
2701               EUg(l,k,i-2)=0.0d0
2702               CUg(l,k,i-2)=0.0d0
2703               DUg(l,k,i-2)=0.0d0
2704               DtUg2(l,k,i-2)=0.0d0
2705             enddo
2706           enddo
2707         endif
2708         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2709         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2710         do k=1,2
2711           muder(k,i-2)=Ub2der(k,i-2)
2712         enddo
2713 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2714         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2715           iti1 = itortyp(itype(i-1))
2716         else
2717           iti1=ntortyp+1
2718         endif
2719         do k=1,2
2720           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2721         enddo
2722 cd        write (iout,*) 'mu ',mu(:,i-2)
2723 cd        write (iout,*) 'mu1',mu1(:,i-2)
2724 cd        write (iout,*) 'mu2',mu2(:,i-2)
2725         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2726      &  then
2727         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2728         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2729         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2730         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2731         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2732 C Vectors and matrices dependent on a single virtual-bond dihedral.
2733         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2734         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2735         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2736         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2737         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2738         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2739         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2740         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2741         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2742         endif
2743       enddo
2744 C Matrices dependent on two consecutive virtual-bond dihedrals.
2745 C The order of matrices is from left to right.
2746       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2747      &then
2748 c      do i=max0(ivec_start,2),ivec_end
2749       do i=2,nres-1
2750         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2751         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2752         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2753         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2754         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2755         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2756         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2757         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2758       enddo
2759       endif
2760 #if defined(MPI) && defined(PARMAT)
2761 #ifdef DEBUG
2762 c      if (fg_rank.eq.0) then
2763         write (iout,*) "Arrays UG and UGDER before GATHER"
2764         do i=1,nres-1
2765           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2766      &     ((ug(l,k,i),l=1,2),k=1,2),
2767      &     ((ugder(l,k,i),l=1,2),k=1,2)
2768         enddo
2769         write (iout,*) "Arrays UG2 and UG2DER"
2770         do i=1,nres-1
2771           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2772      &     ((ug2(l,k,i),l=1,2),k=1,2),
2773      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2774         enddo
2775         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2776         do i=1,nres-1
2777           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2778      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2779      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2780         enddo
2781         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2782         do i=1,nres-1
2783           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2784      &     costab(i),sintab(i),costab2(i),sintab2(i)
2785         enddo
2786         write (iout,*) "Array MUDER"
2787         do i=1,nres-1
2788           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2789         enddo
2790 c      endif
2791 #endif
2792       if (nfgtasks.gt.1) then
2793         time00=MPI_Wtime()
2794 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2795 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2796 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2797 #ifdef MATGATHER
2798         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2799      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2800      &   FG_COMM1,IERR)
2801         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2802      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2803      &   FG_COMM1,IERR)
2804         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2805      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2806      &   FG_COMM1,IERR)
2807         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2808      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2809      &   FG_COMM1,IERR)
2810         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2811      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2812      &   FG_COMM1,IERR)
2813         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2814      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2815      &   FG_COMM1,IERR)
2816         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2817      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2818      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2819         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2820      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2821      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2822         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2823      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2824      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2825         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2826      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2827      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2828         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2829      &  then
2830         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2831      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2832      &   FG_COMM1,IERR)
2833         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2834      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2835      &   FG_COMM1,IERR)
2836         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2837      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2838      &   FG_COMM1,IERR)
2839        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2840      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2841      &   FG_COMM1,IERR)
2842         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2843      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2844      &   FG_COMM1,IERR)
2845         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2846      &   ivec_count(fg_rank1),
2847      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2848      &   FG_COMM1,IERR)
2849         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2850      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2851      &   FG_COMM1,IERR)
2852         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2853      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2854      &   FG_COMM1,IERR)
2855         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2856      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2857      &   FG_COMM1,IERR)
2858         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2859      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2860      &   FG_COMM1,IERR)
2861         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2862      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2863      &   FG_COMM1,IERR)
2864         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2865      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2866      &   FG_COMM1,IERR)
2867         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2868      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2869      &   FG_COMM1,IERR)
2870         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2871      &   ivec_count(fg_rank1),
2872      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2873      &   FG_COMM1,IERR)
2874         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2875      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2876      &   FG_COMM1,IERR)
2877        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2878      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2879      &   FG_COMM1,IERR)
2880         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2881      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2882      &   FG_COMM1,IERR)
2883        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2884      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2885      &   FG_COMM1,IERR)
2886         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2887      &   ivec_count(fg_rank1),
2888      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2889      &   FG_COMM1,IERR)
2890         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2891      &   ivec_count(fg_rank1),
2892      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2893      &   FG_COMM1,IERR)
2894         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2895      &   ivec_count(fg_rank1),
2896      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2897      &   MPI_MAT2,FG_COMM1,IERR)
2898         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2899      &   ivec_count(fg_rank1),
2900      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2901      &   MPI_MAT2,FG_COMM1,IERR)
2902         endif
2903 #else
2904 c Passes matrix info through the ring
2905       isend=fg_rank1
2906       irecv=fg_rank1-1
2907       if (irecv.lt.0) irecv=nfgtasks1-1
2908       iprev=irecv
2909       inext=fg_rank1+1
2910       if (inext.ge.nfgtasks1) inext=0
2911       do i=1,nfgtasks1-1
2912 c        write (iout,*) "isend",isend," irecv",irecv
2913 c        call flush(iout)
2914         lensend=lentyp(isend)
2915         lenrecv=lentyp(irecv)
2916 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2917 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2918 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2919 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2920 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2921 c        write (iout,*) "Gather ROTAT1"
2922 c        call flush(iout)
2923 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2924 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2925 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2926 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2927 c        write (iout,*) "Gather ROTAT2"
2928 c        call flush(iout)
2929         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2930      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2931      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2932      &   iprev,4400+irecv,FG_COMM,status,IERR)
2933 c        write (iout,*) "Gather ROTAT_OLD"
2934 c        call flush(iout)
2935         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2936      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2937      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2938      &   iprev,5500+irecv,FG_COMM,status,IERR)
2939 c        write (iout,*) "Gather PRECOMP11"
2940 c        call flush(iout)
2941         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2942      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2943      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2944      &   iprev,6600+irecv,FG_COMM,status,IERR)
2945 c        write (iout,*) "Gather PRECOMP12"
2946 c        call flush(iout)
2947         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2948      &  then
2949         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2950      &   MPI_ROTAT2(lensend),inext,7700+isend,
2951      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2952      &   iprev,7700+irecv,FG_COMM,status,IERR)
2953 c        write (iout,*) "Gather PRECOMP21"
2954 c        call flush(iout)
2955         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2956      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2957      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2958      &   iprev,8800+irecv,FG_COMM,status,IERR)
2959 c        write (iout,*) "Gather PRECOMP22"
2960 c        call flush(iout)
2961         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2962      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2963      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2964      &   MPI_PRECOMP23(lenrecv),
2965      &   iprev,9900+irecv,FG_COMM,status,IERR)
2966 c        write (iout,*) "Gather PRECOMP23"
2967 c        call flush(iout)
2968         endif
2969         isend=irecv
2970         irecv=irecv-1
2971         if (irecv.lt.0) irecv=nfgtasks1-1
2972       enddo
2973 #endif
2974         time_gather=time_gather+MPI_Wtime()-time00
2975       endif
2976 #ifdef DEBUG
2977 c      if (fg_rank.eq.0) then
2978         write (iout,*) "Arrays UG and UGDER"
2979         do i=1,nres-1
2980           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2981      &     ((ug(l,k,i),l=1,2),k=1,2),
2982      &     ((ugder(l,k,i),l=1,2),k=1,2)
2983         enddo
2984         write (iout,*) "Arrays UG2 and UG2DER"
2985         do i=1,nres-1
2986           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2987      &     ((ug2(l,k,i),l=1,2),k=1,2),
2988      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2989         enddo
2990         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2991         do i=1,nres-1
2992           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2993      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2994      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2995         enddo
2996         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2997         do i=1,nres-1
2998           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2999      &     costab(i),sintab(i),costab2(i),sintab2(i)
3000         enddo
3001         write (iout,*) "Array MUDER"
3002         do i=1,nres-1
3003           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3004         enddo
3005 c      endif
3006 #endif
3007 #endif
3008 cd      do i=1,nres
3009 cd        iti = itortyp(itype(i))
3010 cd        write (iout,*) i
3011 cd        do j=1,2
3012 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3013 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3014 cd        enddo
3015 cd      enddo
3016       return
3017       end
3018 C--------------------------------------------------------------------------
3019       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3020 C
3021 C This subroutine calculates the average interaction energy and its gradient
3022 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3023 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3024 C The potential depends both on the distance of peptide-group centers and on
3025 C the orientation of the CA-CA virtual bonds.
3026 C
3027       implicit real*8 (a-h,o-z)
3028 #ifdef MPI
3029       include 'mpif.h'
3030 #endif
3031       include 'DIMENSIONS'
3032       include 'COMMON.CONTROL'
3033       include 'COMMON.SETUP'
3034       include 'COMMON.IOUNITS'
3035       include 'COMMON.GEO'
3036       include 'COMMON.VAR'
3037       include 'COMMON.LOCAL'
3038       include 'COMMON.CHAIN'
3039       include 'COMMON.DERIV'
3040       include 'COMMON.INTERACT'
3041       include 'COMMON.CONTACTS'
3042       include 'COMMON.TORSION'
3043       include 'COMMON.VECTORS'
3044       include 'COMMON.FFIELD'
3045       include 'COMMON.TIME1'
3046       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3047      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3048       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3049      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3050       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3051      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3052      &    num_conti,j1,j2
3053 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3054 #ifdef MOMENT
3055       double precision scal_el /1.0d0/
3056 #else
3057       double precision scal_el /0.5d0/
3058 #endif
3059 C 12/13/98
3060 C 13-go grudnia roku pamietnego...
3061       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3062      &                   0.0d0,1.0d0,0.0d0,
3063      &                   0.0d0,0.0d0,1.0d0/
3064 cd      write(iout,*) 'In EELEC'
3065 cd      do i=1,nloctyp
3066 cd        write(iout,*) 'Type',i
3067 cd        write(iout,*) 'B1',B1(:,i)
3068 cd        write(iout,*) 'B2',B2(:,i)
3069 cd        write(iout,*) 'CC',CC(:,:,i)
3070 cd        write(iout,*) 'DD',DD(:,:,i)
3071 cd        write(iout,*) 'EE',EE(:,:,i)
3072 cd      enddo
3073 cd      call check_vecgrad
3074 cd      stop
3075       if (icheckgrad.eq.1) then
3076         do i=1,nres-1
3077           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3078           do k=1,3
3079             dc_norm(k,i)=dc(k,i)*fac
3080           enddo
3081 c          write (iout,*) 'i',i,' fac',fac
3082         enddo
3083       endif
3084       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3085      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3086      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3087 c        call vec_and_deriv
3088 #ifdef TIMING
3089         time01=MPI_Wtime()
3090 #endif
3091         call set_matrices
3092 #ifdef TIMING
3093         time_mat=time_mat+MPI_Wtime()-time01
3094 #endif
3095       endif
3096 cd      do i=1,nres-1
3097 cd        write (iout,*) 'i=',i
3098 cd        do k=1,3
3099 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3100 cd        enddo
3101 cd        do k=1,3
3102 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3103 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3104 cd        enddo
3105 cd      enddo
3106       t_eelecij=0.0d0
3107       ees=0.0D0
3108       evdw1=0.0D0
3109       eel_loc=0.0d0
3110       eello_turn3=0.0d0
3111       eello_turn4=0.0d0
3112       ind=0
3113       do i=1,nres
3114         num_cont_hb(i)=0
3115       enddo
3116 cd      print '(a)','Enter EELEC'
3117 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3118       do i=1,nres
3119         gel_loc_loc(i)=0.0d0
3120         gcorr_loc(i)=0.0d0
3121       enddo
3122 c
3123 c
3124 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3125 C
3126 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3127 C
3128       do i=iturn3_start,iturn3_end
3129         dxi=dc(1,i)
3130         dyi=dc(2,i)
3131         dzi=dc(3,i)
3132         dx_normi=dc_norm(1,i)
3133         dy_normi=dc_norm(2,i)
3134         dz_normi=dc_norm(3,i)
3135         xmedi=c(1,i)+0.5d0*dxi
3136         ymedi=c(2,i)+0.5d0*dyi
3137         zmedi=c(3,i)+0.5d0*dzi
3138         num_conti=0
3139         call eelecij(i,i+2,ees,evdw1,eel_loc)
3140         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3141         num_cont_hb(i)=num_conti
3142       enddo
3143       do i=iturn4_start,iturn4_end
3144         dxi=dc(1,i)
3145         dyi=dc(2,i)
3146         dzi=dc(3,i)
3147         dx_normi=dc_norm(1,i)
3148         dy_normi=dc_norm(2,i)
3149         dz_normi=dc_norm(3,i)
3150         xmedi=c(1,i)+0.5d0*dxi
3151         ymedi=c(2,i)+0.5d0*dyi
3152         zmedi=c(3,i)+0.5d0*dzi
3153         num_conti=num_cont_hb(i)
3154         call eelecij(i,i+3,ees,evdw1,eel_loc)
3155         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3156         num_cont_hb(i)=num_conti
3157       enddo   ! i
3158 c
3159 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3160 c
3161       do i=iatel_s,iatel_e
3162         dxi=dc(1,i)
3163         dyi=dc(2,i)
3164         dzi=dc(3,i)
3165         dx_normi=dc_norm(1,i)
3166         dy_normi=dc_norm(2,i)
3167         dz_normi=dc_norm(3,i)
3168         xmedi=c(1,i)+0.5d0*dxi
3169         ymedi=c(2,i)+0.5d0*dyi
3170         zmedi=c(3,i)+0.5d0*dzi
3171 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3172         num_conti=num_cont_hb(i)
3173         do j=ielstart(i),ielend(i)
3174           call eelecij(i,j,ees,evdw1,eel_loc)
3175         enddo ! j
3176         num_cont_hb(i)=num_conti
3177       enddo   ! i
3178 c      write (iout,*) "Number of loop steps in EELEC:",ind
3179 cd      do i=1,nres
3180 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3181 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3182 cd      enddo
3183 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3184 ccc      eel_loc=eel_loc+eello_turn3
3185 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3186       return
3187       end
3188 C-------------------------------------------------------------------------------
3189       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3190       implicit real*8 (a-h,o-z)
3191       include 'DIMENSIONS'
3192 #ifdef MPI
3193       include "mpif.h"
3194 #endif
3195       include 'COMMON.CONTROL'
3196       include 'COMMON.IOUNITS'
3197       include 'COMMON.GEO'
3198       include 'COMMON.VAR'
3199       include 'COMMON.LOCAL'
3200       include 'COMMON.CHAIN'
3201       include 'COMMON.DERIV'
3202       include 'COMMON.INTERACT'
3203       include 'COMMON.CONTACTS'
3204       include 'COMMON.TORSION'
3205       include 'COMMON.VECTORS'
3206       include 'COMMON.FFIELD'
3207       include 'COMMON.TIME1'
3208       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3209      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3210       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3211      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3212       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3213      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3214      &    num_conti,j1,j2
3215 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3216 #ifdef MOMENT
3217       double precision scal_el /1.0d0/
3218 #else
3219       double precision scal_el /0.5d0/
3220 #endif
3221 C 12/13/98
3222 C 13-go grudnia roku pamietnego...
3223       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3224      &                   0.0d0,1.0d0,0.0d0,
3225      &                   0.0d0,0.0d0,1.0d0/
3226 c          time00=MPI_Wtime()
3227 cd      write (iout,*) "eelecij",i,j
3228 c          ind=ind+1
3229           iteli=itel(i)
3230           itelj=itel(j)
3231           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3232           aaa=app(iteli,itelj)
3233           bbb=bpp(iteli,itelj)
3234           ael6i=ael6(iteli,itelj)
3235           ael3i=ael3(iteli,itelj)
3236           dxj=dc(1,j)
3237           dyj=dc(2,j)
3238           dzj=dc(3,j)
3239           dx_normj=dc_norm(1,j)
3240           dy_normj=dc_norm(2,j)
3241           dz_normj=dc_norm(3,j)
3242           xj=c(1,j)+0.5D0*dxj-xmedi
3243           yj=c(2,j)+0.5D0*dyj-ymedi
3244           zj=c(3,j)+0.5D0*dzj-zmedi
3245           rij=xj*xj+yj*yj+zj*zj
3246           rrmij=1.0D0/rij
3247           rij=dsqrt(rij)
3248           rmij=1.0D0/rij
3249           r3ij=rrmij*rmij
3250           r6ij=r3ij*r3ij
3251           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3252           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3253           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3254           fac=cosa-3.0D0*cosb*cosg
3255           ev1=aaa*r6ij*r6ij
3256 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3257           if (j.eq.i+2) ev1=scal_el*ev1
3258           ev2=bbb*r6ij
3259           fac3=ael6i*r6ij
3260           fac4=ael3i*r3ij
3261           evdwij=ev1+ev2
3262           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3263           el2=fac4*fac
3264           eesij=el1+el2
3265 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3266           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3267           ees=ees+eesij
3268           evdw1=evdw1+evdwij
3269 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3270 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3271 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3272 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3273
3274           if (energy_dec) then
3275               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3276               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3277           endif
3278
3279 C
3280 C Calculate contributions to the Cartesian gradient.
3281 C
3282 #ifdef SPLITELE
3283           facvdw=-6*rrmij*(ev1+evdwij)
3284           facel=-3*rrmij*(el1+eesij)
3285           fac1=fac
3286           erij(1)=xj*rmij
3287           erij(2)=yj*rmij
3288           erij(3)=zj*rmij
3289 *
3290 * Radial derivatives. First process both termini of the fragment (i,j)
3291 *
3292           ggg(1)=facel*xj
3293           ggg(2)=facel*yj
3294           ggg(3)=facel*zj
3295 c          do k=1,3
3296 c            ghalf=0.5D0*ggg(k)
3297 c            gelc(k,i)=gelc(k,i)+ghalf
3298 c            gelc(k,j)=gelc(k,j)+ghalf
3299 c          enddo
3300 c 9/28/08 AL Gradient compotents will be summed only at the end
3301           do k=1,3
3302             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3303             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3304           enddo
3305 *
3306 * Loop over residues i+1 thru j-1.
3307 *
3308 cgrad          do k=i+1,j-1
3309 cgrad            do l=1,3
3310 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3311 cgrad            enddo
3312 cgrad          enddo
3313           ggg(1)=facvdw*xj
3314           ggg(2)=facvdw*yj
3315           ggg(3)=facvdw*zj
3316 c          do k=1,3
3317 c            ghalf=0.5D0*ggg(k)
3318 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3319 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3320 c          enddo
3321 c 9/28/08 AL Gradient compotents will be summed only at the end
3322           do k=1,3
3323             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3324             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3325           enddo
3326 *
3327 * Loop over residues i+1 thru j-1.
3328 *
3329 cgrad          do k=i+1,j-1
3330 cgrad            do l=1,3
3331 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3332 cgrad            enddo
3333 cgrad          enddo
3334 #else
3335           facvdw=ev1+evdwij
3336           facel=el1+eesij
3337           fac1=fac
3338           fac=-3*rrmij*(facvdw+facvdw+facel)
3339           erij(1)=xj*rmij
3340           erij(2)=yj*rmij
3341           erij(3)=zj*rmij
3342 *
3343 * Radial derivatives. First process both termini of the fragment (i,j)
3344 *
3345           ggg(1)=fac*xj
3346           ggg(2)=fac*yj
3347           ggg(3)=fac*zj
3348 c          do k=1,3
3349 c            ghalf=0.5D0*ggg(k)
3350 c            gelc(k,i)=gelc(k,i)+ghalf
3351 c            gelc(k,j)=gelc(k,j)+ghalf
3352 c          enddo
3353 c 9/28/08 AL Gradient compotents will be summed only at the end
3354           do k=1,3
3355             gelc_long(k,j)=gelc(k,j)+ggg(k)
3356             gelc_long(k,i)=gelc(k,i)-ggg(k)
3357           enddo
3358 *
3359 * Loop over residues i+1 thru j-1.
3360 *
3361 cgrad          do k=i+1,j-1
3362 cgrad            do l=1,3
3363 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3364 cgrad            enddo
3365 cgrad          enddo
3366 c 9/28/08 AL Gradient compotents will be summed only at the end
3367           ggg(1)=facvdw*xj
3368           ggg(2)=facvdw*yj
3369           ggg(3)=facvdw*zj
3370           do k=1,3
3371             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3372             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3373           enddo
3374 #endif
3375 *
3376 * Angular part
3377 *
3378           ecosa=2.0D0*fac3*fac1+fac4
3379           fac4=-3.0D0*fac4
3380           fac3=-6.0D0*fac3
3381           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3382           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3383           do k=1,3
3384             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3385             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3386           enddo
3387 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3388 cd   &          (dcosg(k),k=1,3)
3389           do k=1,3
3390             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3391           enddo
3392 c          do k=1,3
3393 c            ghalf=0.5D0*ggg(k)
3394 c            gelc(k,i)=gelc(k,i)+ghalf
3395 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3396 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3397 c            gelc(k,j)=gelc(k,j)+ghalf
3398 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3399 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3400 c          enddo
3401 cgrad          do k=i+1,j-1
3402 cgrad            do l=1,3
3403 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3404 cgrad            enddo
3405 cgrad          enddo
3406           do k=1,3
3407             gelc(k,i)=gelc(k,i)
3408      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3409      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3410             gelc(k,j)=gelc(k,j)
3411      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3412      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3413             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3414             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3415           enddo
3416           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3417      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3418      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3419 C
3420 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3421 C   energy of a peptide unit is assumed in the form of a second-order
3422 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3423 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3424 C   are computed for EVERY pair of non-contiguous peptide groups.
3425 C
3426           if (j.lt.nres-1) then
3427             j1=j+1
3428             j2=j-1
3429           else
3430             j1=j-1
3431             j2=j-2
3432           endif
3433           kkk=0
3434           do k=1,2
3435             do l=1,2
3436               kkk=kkk+1
3437               muij(kkk)=mu(k,i)*mu(l,j)
3438             enddo
3439           enddo
3440 cd         write (iout,*) 'EELEC: i',i,' j',j
3441 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3442 cd          write(iout,*) 'muij',muij
3443           ury=scalar(uy(1,i),erij)
3444           urz=scalar(uz(1,i),erij)
3445           vry=scalar(uy(1,j),erij)
3446           vrz=scalar(uz(1,j),erij)
3447           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3448           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3449           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3450           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3451           fac=dsqrt(-ael6i)*r3ij
3452           a22=a22*fac
3453           a23=a23*fac
3454           a32=a32*fac
3455           a33=a33*fac
3456 cd          write (iout,'(4i5,4f10.5)')
3457 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3458 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3459 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3460 cd     &      uy(:,j),uz(:,j)
3461 cd          write (iout,'(4f10.5)')
3462 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3463 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3464 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3465 cd           write (iout,'(9f10.5/)')
3466 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3467 C Derivatives of the elements of A in virtual-bond vectors
3468           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3469           do k=1,3
3470             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3471             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3472             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3473             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3474             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3475             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3476             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3477             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3478             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3479             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3480             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3481             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3482           enddo
3483 C Compute radial contributions to the gradient
3484           facr=-3.0d0*rrmij
3485           a22der=a22*facr
3486           a23der=a23*facr
3487           a32der=a32*facr
3488           a33der=a33*facr
3489           agg(1,1)=a22der*xj
3490           agg(2,1)=a22der*yj
3491           agg(3,1)=a22der*zj
3492           agg(1,2)=a23der*xj
3493           agg(2,2)=a23der*yj
3494           agg(3,2)=a23der*zj
3495           agg(1,3)=a32der*xj
3496           agg(2,3)=a32der*yj
3497           agg(3,3)=a32der*zj
3498           agg(1,4)=a33der*xj
3499           agg(2,4)=a33der*yj
3500           agg(3,4)=a33der*zj
3501 C Add the contributions coming from er
3502           fac3=-3.0d0*fac
3503           do k=1,3
3504             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3505             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3506             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3507             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3508           enddo
3509           do k=1,3
3510 C Derivatives in DC(i)
3511 cgrad            ghalf1=0.5d0*agg(k,1)
3512 cgrad            ghalf2=0.5d0*agg(k,2)
3513 cgrad            ghalf3=0.5d0*agg(k,3)
3514 cgrad            ghalf4=0.5d0*agg(k,4)
3515             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3516      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3517             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3518      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3519             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3520      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3521             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3522      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3523 C Derivatives in DC(i+1)
3524             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3525      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3526             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3527      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3528             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3529      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3530             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3531      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3532 C Derivatives in DC(j)
3533             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3534      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3535             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3536      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3537             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3538      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3539             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3540      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3541 C Derivatives in DC(j+1) or DC(nres-1)
3542             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3543      &      -3.0d0*vryg(k,3)*ury)
3544             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3545      &      -3.0d0*vrzg(k,3)*ury)
3546             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3547      &      -3.0d0*vryg(k,3)*urz)
3548             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3549      &      -3.0d0*vrzg(k,3)*urz)
3550 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3551 cgrad              do l=1,4
3552 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3553 cgrad              enddo
3554 cgrad            endif
3555           enddo
3556           acipa(1,1)=a22
3557           acipa(1,2)=a23
3558           acipa(2,1)=a32
3559           acipa(2,2)=a33
3560           a22=-a22
3561           a23=-a23
3562           do l=1,2
3563             do k=1,3
3564               agg(k,l)=-agg(k,l)
3565               aggi(k,l)=-aggi(k,l)
3566               aggi1(k,l)=-aggi1(k,l)
3567               aggj(k,l)=-aggj(k,l)
3568               aggj1(k,l)=-aggj1(k,l)
3569             enddo
3570           enddo
3571           if (j.lt.nres-1) then
3572             a22=-a22
3573             a32=-a32
3574             do l=1,3,2
3575               do k=1,3
3576                 agg(k,l)=-agg(k,l)
3577                 aggi(k,l)=-aggi(k,l)
3578                 aggi1(k,l)=-aggi1(k,l)
3579                 aggj(k,l)=-aggj(k,l)
3580                 aggj1(k,l)=-aggj1(k,l)
3581               enddo
3582             enddo
3583           else
3584             a22=-a22
3585             a23=-a23
3586             a32=-a32
3587             a33=-a33
3588             do l=1,4
3589               do k=1,3
3590                 agg(k,l)=-agg(k,l)
3591                 aggi(k,l)=-aggi(k,l)
3592                 aggi1(k,l)=-aggi1(k,l)
3593                 aggj(k,l)=-aggj(k,l)
3594                 aggj1(k,l)=-aggj1(k,l)
3595               enddo
3596             enddo
3597           endif
3598           ENDIF ! WCORR
3599           IF (wel_loc.gt.0.0d0) THEN
3600 C Contribution to the local-electrostatic energy coming from the i-j pair
3601           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3602      &     +a33*muij(4)
3603 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3604
3605           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3606      &            'eelloc',i,j,eel_loc_ij
3607
3608           eel_loc=eel_loc+eel_loc_ij
3609 C Partial derivatives in virtual-bond dihedral angles gamma
3610           if (i.gt.1)
3611      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3612      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3613      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3614           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3615      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3616      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3617 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3618           do l=1,3
3619             ggg(l)=agg(l,1)*muij(1)+
3620      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3621             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3622             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3623 cgrad            ghalf=0.5d0*ggg(l)
3624 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3625 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3626           enddo
3627 cgrad          do k=i+1,j2
3628 cgrad            do l=1,3
3629 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3630 cgrad            enddo
3631 cgrad          enddo
3632 C Remaining derivatives of eello
3633           do l=1,3
3634             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3635      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3636             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3637      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3638             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3639      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3640             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3641      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3642           enddo
3643           ENDIF
3644 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3645 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3646           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3647      &       .and. num_conti.le.maxconts) then
3648 c            write (iout,*) i,j," entered corr"
3649 C
3650 C Calculate the contact function. The ith column of the array JCONT will
3651 C contain the numbers of atoms that make contacts with the atom I (of numbers
3652 C greater than I). The arrays FACONT and GACONT will contain the values of
3653 C the contact function and its derivative.
3654 c           r0ij=1.02D0*rpp(iteli,itelj)
3655 c           r0ij=1.11D0*rpp(iteli,itelj)
3656             r0ij=2.20D0*rpp(iteli,itelj)
3657 c           r0ij=1.55D0*rpp(iteli,itelj)
3658             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3659             if (fcont.gt.0.0D0) then
3660               num_conti=num_conti+1
3661               if (num_conti.gt.maxconts) then
3662                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3663      &                         ' will skip next contacts for this conf.'
3664               else
3665                 jcont_hb(num_conti,i)=j
3666 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3667 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3668                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3669      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3670 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3671 C  terms.
3672                 d_cont(num_conti,i)=rij
3673 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3674 C     --- Electrostatic-interaction matrix ---
3675                 a_chuj(1,1,num_conti,i)=a22
3676                 a_chuj(1,2,num_conti,i)=a23
3677                 a_chuj(2,1,num_conti,i)=a32
3678                 a_chuj(2,2,num_conti,i)=a33
3679 C     --- Gradient of rij
3680                 do kkk=1,3
3681                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3682                 enddo
3683                 kkll=0
3684                 do k=1,2
3685                   do l=1,2
3686                     kkll=kkll+1
3687                     do m=1,3
3688                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3689                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3690                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3691                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3692                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3693                     enddo
3694                   enddo
3695                 enddo
3696                 ENDIF
3697                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3698 C Calculate contact energies
3699                 cosa4=4.0D0*cosa
3700                 wij=cosa-3.0D0*cosb*cosg
3701                 cosbg1=cosb+cosg
3702                 cosbg2=cosb-cosg
3703 c               fac3=dsqrt(-ael6i)/r0ij**3
3704                 fac3=dsqrt(-ael6i)*r3ij
3705 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3706                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3707                 if (ees0tmp.gt.0) then
3708                   ees0pij=dsqrt(ees0tmp)
3709                 else
3710                   ees0pij=0
3711                 endif
3712 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3713                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3714                 if (ees0tmp.gt.0) then
3715                   ees0mij=dsqrt(ees0tmp)
3716                 else
3717                   ees0mij=0
3718                 endif
3719 c               ees0mij=0.0D0
3720                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3721                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3722 C Diagnostics. Comment out or remove after debugging!
3723 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3724 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3725 c               ees0m(num_conti,i)=0.0D0
3726 C End diagnostics.
3727 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3728 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3729 C Angular derivatives of the contact function
3730                 ees0pij1=fac3/ees0pij
3731                 ees0mij1=fac3/ees0mij
3732                 fac3p=-3.0D0*fac3*rrmij
3733                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3734                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3735 c               ees0mij1=0.0D0
3736                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3737                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3738                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3739                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3740                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3741                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3742                 ecosap=ecosa1+ecosa2
3743                 ecosbp=ecosb1+ecosb2
3744                 ecosgp=ecosg1+ecosg2
3745                 ecosam=ecosa1-ecosa2
3746                 ecosbm=ecosb1-ecosb2
3747                 ecosgm=ecosg1-ecosg2
3748 C Diagnostics
3749 c               ecosap=ecosa1
3750 c               ecosbp=ecosb1
3751 c               ecosgp=ecosg1
3752 c               ecosam=0.0D0
3753 c               ecosbm=0.0D0
3754 c               ecosgm=0.0D0
3755 C End diagnostics
3756                 facont_hb(num_conti,i)=fcont
3757                 fprimcont=fprimcont/rij
3758 cd              facont_hb(num_conti,i)=1.0D0
3759 C Following line is for diagnostics.
3760 cd              fprimcont=0.0D0
3761                 do k=1,3
3762                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3763                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3764                 enddo
3765                 do k=1,3
3766                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3767                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3768                 enddo
3769                 gggp(1)=gggp(1)+ees0pijp*xj
3770                 gggp(2)=gggp(2)+ees0pijp*yj
3771                 gggp(3)=gggp(3)+ees0pijp*zj
3772                 gggm(1)=gggm(1)+ees0mijp*xj
3773                 gggm(2)=gggm(2)+ees0mijp*yj
3774                 gggm(3)=gggm(3)+ees0mijp*zj
3775 C Derivatives due to the contact function
3776                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3777                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3778                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3779                 do k=1,3
3780 c
3781 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3782 c          following the change of gradient-summation algorithm.
3783 c
3784 cgrad                  ghalfp=0.5D0*gggp(k)
3785 cgrad                  ghalfm=0.5D0*gggm(k)
3786                   gacontp_hb1(k,num_conti,i)=!ghalfp
3787      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3788      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3789                   gacontp_hb2(k,num_conti,i)=!ghalfp
3790      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3791      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3792                   gacontp_hb3(k,num_conti,i)=gggp(k)
3793                   gacontm_hb1(k,num_conti,i)=!ghalfm
3794      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3795      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3796                   gacontm_hb2(k,num_conti,i)=!ghalfm
3797      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3798      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3799                   gacontm_hb3(k,num_conti,i)=gggm(k)
3800                 enddo
3801 C Diagnostics. Comment out or remove after debugging!
3802 cdiag           do k=1,3
3803 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3804 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3805 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3806 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3807 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3808 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3809 cdiag           enddo
3810               ENDIF ! wcorr
3811               endif  ! num_conti.le.maxconts
3812             endif  ! fcont.gt.0
3813           endif    ! j.gt.i+1
3814           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3815             do k=1,4
3816               do l=1,3
3817                 ghalf=0.5d0*agg(l,k)
3818                 aggi(l,k)=aggi(l,k)+ghalf
3819                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3820                 aggj(l,k)=aggj(l,k)+ghalf
3821               enddo
3822             enddo
3823             if (j.eq.nres-1 .and. i.lt.j-2) then
3824               do k=1,4
3825                 do l=1,3
3826                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3827                 enddo
3828               enddo
3829             endif
3830           endif
3831 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3832       return
3833       end
3834 C-----------------------------------------------------------------------------
3835       subroutine eturn3(i,eello_turn3)
3836 C Third- and fourth-order contributions from turns
3837       implicit real*8 (a-h,o-z)
3838       include 'DIMENSIONS'
3839       include 'COMMON.IOUNITS'
3840       include 'COMMON.GEO'
3841       include 'COMMON.VAR'
3842       include 'COMMON.LOCAL'
3843       include 'COMMON.CHAIN'
3844       include 'COMMON.DERIV'
3845       include 'COMMON.INTERACT'
3846       include 'COMMON.CONTACTS'
3847       include 'COMMON.TORSION'
3848       include 'COMMON.VECTORS'
3849       include 'COMMON.FFIELD'
3850       include 'COMMON.CONTROL'
3851       dimension ggg(3)
3852       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3853      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3854      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3855       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3856      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3857       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3858      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3859      &    num_conti,j1,j2
3860       j=i+2
3861 c      write (iout,*) "eturn3",i,j,j1,j2
3862       a_temp(1,1)=a22
3863       a_temp(1,2)=a23
3864       a_temp(2,1)=a32
3865       a_temp(2,2)=a33
3866 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3867 C
3868 C               Third-order contributions
3869 C
3870 C                 (i+2)o----(i+3)
3871 C                      | |
3872 C                      | |
3873 C                 (i+1)o----i
3874 C
3875 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3876 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3877         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3878         call transpose2(auxmat(1,1),auxmat1(1,1))
3879         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3880         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3881         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3882      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3883 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3884 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3885 cd     &    ' eello_turn3_num',4*eello_turn3_num
3886 C Derivatives in gamma(i)
3887         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3888         call transpose2(auxmat2(1,1),auxmat3(1,1))
3889         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3890         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3891 C Derivatives in gamma(i+1)
3892         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3893         call transpose2(auxmat2(1,1),auxmat3(1,1))
3894         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3895         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3896      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3897 C Cartesian derivatives
3898 !DIR$ UNROLL(0)
3899         do l=1,3
3900 c            ghalf1=0.5d0*agg(l,1)
3901 c            ghalf2=0.5d0*agg(l,2)
3902 c            ghalf3=0.5d0*agg(l,3)
3903 c            ghalf4=0.5d0*agg(l,4)
3904           a_temp(1,1)=aggi(l,1)!+ghalf1
3905           a_temp(1,2)=aggi(l,2)!+ghalf2
3906           a_temp(2,1)=aggi(l,3)!+ghalf3
3907           a_temp(2,2)=aggi(l,4)!+ghalf4
3908           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3909           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3910      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3911           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3912           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3913           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3914           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3915           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3916           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3917      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3918           a_temp(1,1)=aggj(l,1)!+ghalf1
3919           a_temp(1,2)=aggj(l,2)!+ghalf2
3920           a_temp(2,1)=aggj(l,3)!+ghalf3
3921           a_temp(2,2)=aggj(l,4)!+ghalf4
3922           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3923           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3924      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3925           a_temp(1,1)=aggj1(l,1)
3926           a_temp(1,2)=aggj1(l,2)
3927           a_temp(2,1)=aggj1(l,3)
3928           a_temp(2,2)=aggj1(l,4)
3929           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3930           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3931      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3932         enddo
3933       return
3934       end
3935 C-------------------------------------------------------------------------------
3936       subroutine eturn4(i,eello_turn4)
3937 C Third- and fourth-order contributions from turns
3938       implicit real*8 (a-h,o-z)
3939       include 'DIMENSIONS'
3940       include 'COMMON.IOUNITS'
3941       include 'COMMON.GEO'
3942       include 'COMMON.VAR'
3943       include 'COMMON.LOCAL'
3944       include 'COMMON.CHAIN'
3945       include 'COMMON.DERIV'
3946       include 'COMMON.INTERACT'
3947       include 'COMMON.CONTACTS'
3948       include 'COMMON.TORSION'
3949       include 'COMMON.VECTORS'
3950       include 'COMMON.FFIELD'
3951       include 'COMMON.CONTROL'
3952       dimension ggg(3)
3953       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3954      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3955      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3956       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3957      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3958       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3959      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3960      &    num_conti,j1,j2
3961       j=i+3
3962 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3963 C
3964 C               Fourth-order contributions
3965 C
3966 C                 (i+3)o----(i+4)
3967 C                     /  |
3968 C               (i+2)o   |
3969 C                     \  |
3970 C                 (i+1)o----i
3971 C
3972 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3973 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3974 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3975         a_temp(1,1)=a22
3976         a_temp(1,2)=a23
3977         a_temp(2,1)=a32
3978         a_temp(2,2)=a33
3979         iti1=itortyp(itype(i+1))
3980         iti2=itortyp(itype(i+2))
3981         iti3=itortyp(itype(i+3))
3982 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3983         call transpose2(EUg(1,1,i+1),e1t(1,1))
3984         call transpose2(Eug(1,1,i+2),e2t(1,1))
3985         call transpose2(Eug(1,1,i+3),e3t(1,1))
3986         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3987         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3988         s1=scalar2(b1(1,iti2),auxvec(1))
3989         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3990         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3991         s2=scalar2(b1(1,iti1),auxvec(1))
3992         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3993         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3994         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3995         eello_turn4=eello_turn4-(s1+s2+s3)
3996         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3997      &      'eturn4',i,j,-(s1+s2+s3)
3998 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3999 cd     &    ' eello_turn4_num',8*eello_turn4_num
4000 C Derivatives in gamma(i)
4001         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4002         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4003         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4004         s1=scalar2(b1(1,iti2),auxvec(1))
4005         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4006         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4007         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
4008 C Derivatives in gamma(i+1)
4009         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4010         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4011         s2=scalar2(b1(1,iti1),auxvec(1))
4012         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4013         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4014         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4015         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
4016 C Derivatives in gamma(i+2)
4017         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4018         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4019         s1=scalar2(b1(1,iti2),auxvec(1))
4020         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4021         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4022         s2=scalar2(b1(1,iti1),auxvec(1))
4023         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4024         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4025         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4026         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4027 C Cartesian derivatives
4028 C Derivatives of this turn contributions in DC(i+2)
4029         if (j.lt.nres-1) then
4030           do l=1,3
4031             a_temp(1,1)=agg(l,1)
4032             a_temp(1,2)=agg(l,2)
4033             a_temp(2,1)=agg(l,3)
4034             a_temp(2,2)=agg(l,4)
4035             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4036             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4037             s1=scalar2(b1(1,iti2),auxvec(1))
4038             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4039             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4040             s2=scalar2(b1(1,iti1),auxvec(1))
4041             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4042             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4043             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4044             ggg(l)=-(s1+s2+s3)
4045             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4046           enddo
4047         endif
4048 C Remaining derivatives of this turn contribution
4049         do l=1,3
4050           a_temp(1,1)=aggi(l,1)
4051           a_temp(1,2)=aggi(l,2)
4052           a_temp(2,1)=aggi(l,3)
4053           a_temp(2,2)=aggi(l,4)
4054           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4055           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4056           s1=scalar2(b1(1,iti2),auxvec(1))
4057           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4058           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4059           s2=scalar2(b1(1,iti1),auxvec(1))
4060           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4061           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4062           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4063           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4064           a_temp(1,1)=aggi1(l,1)
4065           a_temp(1,2)=aggi1(l,2)
4066           a_temp(2,1)=aggi1(l,3)
4067           a_temp(2,2)=aggi1(l,4)
4068           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4069           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4070           s1=scalar2(b1(1,iti2),auxvec(1))
4071           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4072           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4073           s2=scalar2(b1(1,iti1),auxvec(1))
4074           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4075           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4076           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4077           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4078           a_temp(1,1)=aggj(l,1)
4079           a_temp(1,2)=aggj(l,2)
4080           a_temp(2,1)=aggj(l,3)
4081           a_temp(2,2)=aggj(l,4)
4082           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4083           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4084           s1=scalar2(b1(1,iti2),auxvec(1))
4085           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4086           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4087           s2=scalar2(b1(1,iti1),auxvec(1))
4088           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4089           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4090           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4091           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4092           a_temp(1,1)=aggj1(l,1)
4093           a_temp(1,2)=aggj1(l,2)
4094           a_temp(2,1)=aggj1(l,3)
4095           a_temp(2,2)=aggj1(l,4)
4096           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4097           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4098           s1=scalar2(b1(1,iti2),auxvec(1))
4099           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4100           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4101           s2=scalar2(b1(1,iti1),auxvec(1))
4102           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4103           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4104           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4105 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4106           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4107         enddo
4108       return
4109       end
4110 C-----------------------------------------------------------------------------
4111       subroutine vecpr(u,v,w)
4112       implicit real*8(a-h,o-z)
4113       dimension u(3),v(3),w(3)
4114       w(1)=u(2)*v(3)-u(3)*v(2)
4115       w(2)=-u(1)*v(3)+u(3)*v(1)
4116       w(3)=u(1)*v(2)-u(2)*v(1)
4117       return
4118       end
4119 C-----------------------------------------------------------------------------
4120       subroutine unormderiv(u,ugrad,unorm,ungrad)
4121 C This subroutine computes the derivatives of a normalized vector u, given
4122 C the derivatives computed without normalization conditions, ugrad. Returns
4123 C ungrad.
4124       implicit none
4125       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4126       double precision vec(3)
4127       double precision scalar
4128       integer i,j
4129 c      write (2,*) 'ugrad',ugrad
4130 c      write (2,*) 'u',u
4131       do i=1,3
4132         vec(i)=scalar(ugrad(1,i),u(1))
4133       enddo
4134 c      write (2,*) 'vec',vec
4135       do i=1,3
4136         do j=1,3
4137           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4138         enddo
4139       enddo
4140 c      write (2,*) 'ungrad',ungrad
4141       return
4142       end
4143 C-----------------------------------------------------------------------------
4144       subroutine escp_soft_sphere(evdw2,evdw2_14)
4145 C
4146 C This subroutine calculates the excluded-volume interaction energy between
4147 C peptide-group centers and side chains and its gradient in virtual-bond and
4148 C side-chain vectors.
4149 C
4150       implicit real*8 (a-h,o-z)
4151       include 'DIMENSIONS'
4152       include 'COMMON.GEO'
4153       include 'COMMON.VAR'
4154       include 'COMMON.LOCAL'
4155       include 'COMMON.CHAIN'
4156       include 'COMMON.DERIV'
4157       include 'COMMON.INTERACT'
4158       include 'COMMON.FFIELD'
4159       include 'COMMON.IOUNITS'
4160       include 'COMMON.CONTROL'
4161       dimension ggg(3)
4162       evdw2=0.0D0
4163       evdw2_14=0.0d0
4164       r0_scp=4.5d0
4165 cd    print '(a)','Enter ESCP'
4166 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4167       do i=iatscp_s,iatscp_e
4168         iteli=itel(i)
4169         xi=0.5D0*(c(1,i)+c(1,i+1))
4170         yi=0.5D0*(c(2,i)+c(2,i+1))
4171         zi=0.5D0*(c(3,i)+c(3,i+1))
4172
4173         do iint=1,nscp_gr(i)
4174
4175         do j=iscpstart(i,iint),iscpend(i,iint)
4176           itypj=itype(j)
4177 C Uncomment following three lines for SC-p interactions
4178 c         xj=c(1,nres+j)-xi
4179 c         yj=c(2,nres+j)-yi
4180 c         zj=c(3,nres+j)-zi
4181 C Uncomment following three lines for Ca-p interactions
4182           xj=c(1,j)-xi
4183           yj=c(2,j)-yi
4184           zj=c(3,j)-zi
4185           rij=xj*xj+yj*yj+zj*zj
4186           r0ij=r0_scp
4187           r0ijsq=r0ij*r0ij
4188           if (rij.lt.r0ijsq) then
4189             evdwij=0.25d0*(rij-r0ijsq)**2
4190             fac=rij-r0ijsq
4191           else
4192             evdwij=0.0d0
4193             fac=0.0d0
4194           endif
4195           evdw2=evdw2+evdwij
4196 C
4197 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4198 C
4199           ggg(1)=xj*fac
4200           ggg(2)=yj*fac
4201           ggg(3)=zj*fac
4202 cgrad          if (j.lt.i) then
4203 cd          write (iout,*) 'j<i'
4204 C Uncomment following three lines for SC-p interactions
4205 c           do k=1,3
4206 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4207 c           enddo
4208 cgrad          else
4209 cd          write (iout,*) 'j>i'
4210 cgrad            do k=1,3
4211 cgrad              ggg(k)=-ggg(k)
4212 C Uncomment following line for SC-p interactions
4213 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4214 cgrad            enddo
4215 cgrad          endif
4216 cgrad          do k=1,3
4217 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4218 cgrad          enddo
4219 cgrad          kstart=min0(i+1,j)
4220 cgrad          kend=max0(i-1,j-1)
4221 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4222 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4223 cgrad          do k=kstart,kend
4224 cgrad            do l=1,3
4225 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4226 cgrad            enddo
4227 cgrad          enddo
4228           do k=1,3
4229             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4230             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4231           enddo
4232         enddo
4233
4234         enddo ! iint
4235       enddo ! i
4236       return
4237       end
4238 C-----------------------------------------------------------------------------
4239       subroutine escp(evdw2,evdw2_14)
4240 C
4241 C This subroutine calculates the excluded-volume interaction energy between
4242 C peptide-group centers and side chains and its gradient in virtual-bond and
4243 C side-chain vectors.
4244 C
4245       implicit real*8 (a-h,o-z)
4246       include 'DIMENSIONS'
4247       include 'COMMON.GEO'
4248       include 'COMMON.VAR'
4249       include 'COMMON.LOCAL'
4250       include 'COMMON.CHAIN'
4251       include 'COMMON.DERIV'
4252       include 'COMMON.INTERACT'
4253       include 'COMMON.FFIELD'
4254       include 'COMMON.IOUNITS'
4255       include 'COMMON.CONTROL'
4256       dimension ggg(3)
4257       evdw2=0.0D0
4258       evdw2_14=0.0d0
4259 cd    print '(a)','Enter ESCP'
4260 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4261       do i=iatscp_s,iatscp_e
4262         iteli=itel(i)
4263         xi=0.5D0*(c(1,i)+c(1,i+1))
4264         yi=0.5D0*(c(2,i)+c(2,i+1))
4265         zi=0.5D0*(c(3,i)+c(3,i+1))
4266
4267         do iint=1,nscp_gr(i)
4268
4269         do j=iscpstart(i,iint),iscpend(i,iint)
4270           itypj=itype(j)
4271 C Uncomment following three lines for SC-p interactions
4272 c         xj=c(1,nres+j)-xi
4273 c         yj=c(2,nres+j)-yi
4274 c         zj=c(3,nres+j)-zi
4275 C Uncomment following three lines for Ca-p interactions
4276           xj=c(1,j)-xi
4277           yj=c(2,j)-yi
4278           zj=c(3,j)-zi
4279           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4280           fac=rrij**expon2
4281           e1=fac*fac*aad(itypj,iteli)
4282           e2=fac*bad(itypj,iteli)
4283           if (iabs(j-i) .le. 2) then
4284             e1=scal14*e1
4285             e2=scal14*e2
4286             evdw2_14=evdw2_14+e1+e2
4287           endif
4288           evdwij=e1+e2
4289           evdw2=evdw2+evdwij
4290           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4291      &        'evdw2',i,j,evdwij
4292 C
4293 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4294 C
4295           fac=-(evdwij+e1)*rrij
4296           ggg(1)=xj*fac
4297           ggg(2)=yj*fac
4298           ggg(3)=zj*fac
4299 cgrad          if (j.lt.i) then
4300 cd          write (iout,*) 'j<i'
4301 C Uncomment following three lines for SC-p interactions
4302 c           do k=1,3
4303 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4304 c           enddo
4305 cgrad          else
4306 cd          write (iout,*) 'j>i'
4307 cgrad            do k=1,3
4308 cgrad              ggg(k)=-ggg(k)
4309 C Uncomment following line for SC-p interactions
4310 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4311 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4312 cgrad            enddo
4313 cgrad          endif
4314 cgrad          do k=1,3
4315 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4316 cgrad          enddo
4317 cgrad          kstart=min0(i+1,j)
4318 cgrad          kend=max0(i-1,j-1)
4319 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4320 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4321 cgrad          do k=kstart,kend
4322 cgrad            do l=1,3
4323 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4324 cgrad            enddo
4325 cgrad          enddo
4326           do k=1,3
4327             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4328             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4329           enddo
4330         enddo
4331
4332         enddo ! iint
4333       enddo ! i
4334       do i=1,nct
4335         do j=1,3
4336           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4337           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4338           gradx_scp(j,i)=expon*gradx_scp(j,i)
4339         enddo
4340       enddo
4341 C******************************************************************************
4342 C
4343 C                              N O T E !!!
4344 C
4345 C To save time the factor EXPON has been extracted from ALL components
4346 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4347 C use!
4348 C
4349 C******************************************************************************
4350       return
4351       end
4352 C--------------------------------------------------------------------------
4353       subroutine edis(ehpb)
4354 C
4355 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4356 C
4357       implicit real*8 (a-h,o-z)
4358       include 'DIMENSIONS'
4359       include 'COMMON.SBRIDGE'
4360       include 'COMMON.CHAIN'
4361       include 'COMMON.DERIV'
4362       include 'COMMON.VAR'
4363       include 'COMMON.INTERACT'
4364       include 'COMMON.IOUNITS'
4365       include 'COMMON.CONTROL'
4366       dimension ggg(3)
4367       ehpb=0.0D0
4368       do i=1,3
4369        ggg(i)=0.0d0
4370       enddo
4371 C      write (iout,*) ,"link_end",link_end,constr_dist
4372 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4373 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4374 c     &  " constr_dist",constr_dist
4375       if (link_end.eq.0) return
4376       do i=link_start,link_end
4377 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4378 C CA-CA distance used in regularization of structure.
4379         ii=ihpb(i)
4380         jj=jhpb(i)
4381 C iii and jjj point to the residues for which the distance is assigned.
4382         if (ii.gt.nres) then
4383           iii=ii-nres
4384           jjj=jj-nres
4385         else
4386           iii=ii
4387           jjj=jj
4388         endif
4389 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4390 c     &    dhpb(i),dhpb1(i),forcon(i)
4391 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4392 C    distance and angle dependent SS bond potential.
4393 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4394 C     & iabs(itype(jjj)).eq.1) then
4395 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4396 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4397         if (.not.dyn_ss .and. i.le.nss) then
4398 C 15/02/13 CC dynamic SSbond - additional check
4399           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4400      &        iabs(itype(jjj)).eq.1) then
4401            call ssbond_ene(iii,jjj,eij)
4402            ehpb=ehpb+2*eij
4403          endif
4404 cd          write (iout,*) "eij",eij
4405 cd   &   ' waga=',waga,' fac=',fac
4406 !        else if (ii.gt.nres .and. jj.gt.nres) then
4407         else
4408 C Calculate the distance between the two points and its difference from the
4409 C target distance.
4410           dd=dist(ii,jj)
4411           if (irestr_type(i).eq.11) then
4412             ehpb=ehpb+fordepth(i)!**4.0d0
4413      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4414             fac=fordepth(i)!**4.0d0
4415      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4416             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4417      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4418      &        ehpb,irestr_type(i)
4419           else if (irestr_type(i).eq.10) then
4420 c AL 6//19/2018 cross-link restraints
4421             xdis = 0.5d0*(dd/forcon(i))**2
4422             expdis = dexp(-xdis)
4423 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4424             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4425 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4426 c     &          " wboltzd",wboltzd
4427             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4428 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4429             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4430      &           *expdis/(aux*forcon(i)**2)
4431             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4432      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4433      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4434           else if (irestr_type(i).eq.2) then
4435 c Quartic restraints
4436             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4437             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4438      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4439      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4440             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4441           else
4442 c Quadratic restraints
4443             rdis=dd-dhpb(i)
4444 C Get the force constant corresponding to this distance.
4445             waga=forcon(i)
4446 C Calculate the contribution to energy.
4447             ehpb=ehpb+0.5d0*waga*rdis*rdis
4448             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4449      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4450      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4451 C
4452 C Evaluate gradient.
4453 C
4454             fac=waga*rdis/dd
4455           endif
4456 c Calculate Cartesian gradient
4457           do j=1,3
4458             ggg(j)=fac*(c(j,jj)-c(j,ii))
4459           enddo
4460 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4461 C If this is a SC-SC distance, we need to calculate the contributions to the
4462 C Cartesian gradient in the SC vectors (ghpbx).
4463           if (iii.lt.ii) then
4464             do j=1,3
4465               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4466               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4467             enddo
4468           endif
4469 cgrad        do j=iii,jjj-1
4470 cgrad          do k=1,3
4471 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4472 cgrad          enddo
4473 cgrad        enddo
4474           do k=1,3
4475             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4476             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4477           enddo
4478         endif
4479       enddo
4480       return
4481       end
4482 C--------------------------------------------------------------------------
4483       subroutine ssbond_ene(i,j,eij)
4484 C
4485 C Calculate the distance and angle dependent SS-bond potential energy
4486 C using a free-energy function derived based on RHF/6-31G** ab initio
4487 C calculations of diethyl disulfide.
4488 C
4489 C A. Liwo and U. Kozlowska, 11/24/03
4490 C
4491       implicit real*8 (a-h,o-z)
4492       include 'DIMENSIONS'
4493       include 'COMMON.SBRIDGE'
4494       include 'COMMON.CHAIN'
4495       include 'COMMON.DERIV'
4496       include 'COMMON.LOCAL'
4497       include 'COMMON.INTERACT'
4498       include 'COMMON.VAR'
4499       include 'COMMON.IOUNITS'
4500       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4501       itypi=itype(i)
4502       xi=c(1,nres+i)
4503       yi=c(2,nres+i)
4504       zi=c(3,nres+i)
4505       dxi=dc_norm(1,nres+i)
4506       dyi=dc_norm(2,nres+i)
4507       dzi=dc_norm(3,nres+i)
4508 c      dsci_inv=dsc_inv(itypi)
4509       dsci_inv=vbld_inv(nres+i)
4510       itypj=itype(j)
4511 c      dscj_inv=dsc_inv(itypj)
4512       dscj_inv=vbld_inv(nres+j)
4513       xj=c(1,nres+j)-xi
4514       yj=c(2,nres+j)-yi
4515       zj=c(3,nres+j)-zi
4516       dxj=dc_norm(1,nres+j)
4517       dyj=dc_norm(2,nres+j)
4518       dzj=dc_norm(3,nres+j)
4519       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4520       rij=dsqrt(rrij)
4521       erij(1)=xj*rij
4522       erij(2)=yj*rij
4523       erij(3)=zj*rij
4524       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4525       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4526       om12=dxi*dxj+dyi*dyj+dzi*dzj
4527       do k=1,3
4528         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4529         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4530       enddo
4531       rij=1.0d0/rij
4532       deltad=rij-d0cm
4533       deltat1=1.0d0-om1
4534       deltat2=1.0d0+om2
4535       deltat12=om2-om1+2.0d0
4536       cosphi=om12-om1*om2
4537       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4538      &  +akct*deltad*deltat12+ebr
4539      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4540 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4541 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4542 c     &  " deltat12",deltat12," eij",eij
4543       ed=2*akcm*deltad+akct*deltat12
4544       pom1=akct*deltad
4545       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4546       eom1=-2*akth*deltat1-pom1-om2*pom2
4547       eom2= 2*akth*deltat2+pom1-om1*pom2
4548       eom12=pom2
4549       do k=1,3
4550         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4551         ghpbx(k,i)=ghpbx(k,i)-ggk
4552      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4553      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4554         ghpbx(k,j)=ghpbx(k,j)+ggk
4555      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4556      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4557         ghpbc(k,i)=ghpbc(k,i)-ggk
4558         ghpbc(k,j)=ghpbc(k,j)+ggk
4559       enddo
4560 C
4561 C Calculate the components of the gradient in DC and X
4562 C
4563 cgrad      do k=i,j-1
4564 cgrad        do l=1,3
4565 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4566 cgrad        enddo
4567 cgrad      enddo
4568       return
4569       end
4570 C--------------------------------------------------------------------------
4571       subroutine ebond(estr)
4572 c
4573 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4574 c
4575       implicit real*8 (a-h,o-z)
4576       include 'DIMENSIONS'
4577       include 'COMMON.LOCAL'
4578       include 'COMMON.GEO'
4579       include 'COMMON.INTERACT'
4580       include 'COMMON.DERIV'
4581       include 'COMMON.VAR'
4582       include 'COMMON.CHAIN'
4583       include 'COMMON.IOUNITS'
4584       include 'COMMON.NAMES'
4585       include 'COMMON.FFIELD'
4586       include 'COMMON.CONTROL'
4587       include 'COMMON.SETUP'
4588       double precision u(3),ud(3)
4589       estr=0.0d0
4590       do i=ibondp_start,ibondp_end
4591         diff = vbld(i)-vbldp0
4592 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4593         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4594      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4595         estr=estr+diff*diff
4596         do j=1,3
4597           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4598         enddo
4599 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4600       enddo
4601       estr=0.5d0*AKP*estr
4602 c
4603 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4604 c
4605       do i=ibond_start,ibond_end
4606         iti=itype(i)
4607         if (iti.ne.10) then
4608           nbi=nbondterm(iti)
4609           if (nbi.eq.1) then
4610             diff=vbld(i+nres)-vbldsc0(1,iti)
4611 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4612 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4613             if (energy_dec)  then
4614               write (iout,*)
4615      &         "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4616      &         AKSC(1,iti),AKSC(1,iti)*diff*diff
4617               call flush(iout)
4618             endif
4619             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4620             do j=1,3
4621               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4622             enddo
4623           else
4624             do j=1,nbi
4625               diff=vbld(i+nres)-vbldsc0(j,iti)
4626               ud(j)=aksc(j,iti)*diff
4627               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4628             enddo
4629             uprod=u(1)
4630             do j=2,nbi
4631               uprod=uprod*u(j)
4632             enddo
4633             usum=0.0d0
4634             usumsqder=0.0d0
4635             do j=1,nbi
4636               uprod1=1.0d0
4637               uprod2=1.0d0
4638               do k=1,nbi
4639                 if (k.ne.j) then
4640                   uprod1=uprod1*u(k)
4641                   uprod2=uprod2*u(k)*u(k)
4642                 endif
4643               enddo
4644               usum=usum+uprod1
4645               usumsqder=usumsqder+ud(j)*uprod2
4646             enddo
4647             estr=estr+uprod/usum
4648             do j=1,3
4649              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4650             enddo
4651           endif
4652         endif
4653       enddo
4654       return
4655       end
4656 #ifdef CRYST_THETA
4657 C--------------------------------------------------------------------------
4658       subroutine ebend(etheta)
4659 C
4660 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4661 C angles gamma and its derivatives in consecutive thetas and gammas.
4662 C
4663       implicit real*8 (a-h,o-z)
4664       include 'DIMENSIONS'
4665       include 'COMMON.LOCAL'
4666       include 'COMMON.GEO'
4667       include 'COMMON.INTERACT'
4668       include 'COMMON.DERIV'
4669       include 'COMMON.VAR'
4670       include 'COMMON.CHAIN'
4671       include 'COMMON.IOUNITS'
4672       include 'COMMON.NAMES'
4673       include 'COMMON.FFIELD'
4674       include 'COMMON.CONTROL'
4675       common /calcthet/ term1,term2,termm,diffak,ratak,
4676      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4677      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4678       double precision y(2),z(2)
4679       delta=0.02d0*pi
4680 c      time11=dexp(-2*time)
4681 c      time12=1.0d0
4682       etheta=0.0D0
4683 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4684       do i=ithet_start,ithet_end
4685 C Zero the energy function and its derivative at 0 or pi.
4686         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4687         it=itype(i-1)
4688         if (i.gt.3) then
4689 #ifdef OSF
4690           phii=phi(i)
4691           if (phii.ne.phii) phii=150.0
4692 #else
4693           phii=phi(i)
4694 #endif
4695           y(1)=dcos(phii)
4696           y(2)=dsin(phii)
4697         else
4698           y(1)=0.0D0
4699           y(2)=0.0D0
4700         endif
4701         if (i.lt.nres) then
4702 #ifdef OSF
4703           phii1=phi(i+1)
4704           if (phii1.ne.phii1) phii1=150.0
4705           phii1=pinorm(phii1)
4706           z(1)=cos(phii1)
4707 #else
4708           phii1=phi(i+1)
4709           z(1)=dcos(phii1)
4710 #endif
4711           z(2)=dsin(phii1)
4712         else
4713           z(1)=0.0D0
4714           z(2)=0.0D0
4715         endif
4716 C Calculate the "mean" value of theta from the part of the distribution
4717 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4718 C In following comments this theta will be referred to as t_c.
4719         thet_pred_mean=0.0d0
4720         do k=1,2
4721           athetk=athet(k,it)
4722           bthetk=bthet(k,it)
4723           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4724         enddo
4725         dthett=thet_pred_mean*ssd
4726         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4727 C Derivatives of the "mean" values in gamma1 and gamma2.
4728         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4729         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4730         if (theta(i).gt.pi-delta) then
4731           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4732      &         E_tc0)
4733           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4734           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4735           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4736      &        E_theta)
4737           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4738      &        E_tc)
4739         else if (theta(i).lt.delta) then
4740           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4741           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4742           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4743      &        E_theta)
4744           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4745           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4746      &        E_tc)
4747         else
4748           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4749      &        E_theta,E_tc)
4750         endif
4751         etheta=etheta+ethetai
4752         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4753      &      'ebend',i,ethetai
4754         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4755         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4756         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4757       enddo
4758 C Ufff.... We've done all this!!!
4759       return
4760       end
4761 C---------------------------------------------------------------------------
4762       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4763      &     E_tc)
4764       implicit real*8 (a-h,o-z)
4765       include 'DIMENSIONS'
4766       include 'COMMON.LOCAL'
4767       include 'COMMON.IOUNITS'
4768       common /calcthet/ term1,term2,termm,diffak,ratak,
4769      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4770      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4771 C Calculate the contributions to both Gaussian lobes.
4772 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4773 C The "polynomial part" of the "standard deviation" of this part of
4774 C the distribution.
4775         sig=polthet(3,it)
4776         do j=2,0,-1
4777           sig=sig*thet_pred_mean+polthet(j,it)
4778         enddo
4779 C Derivative of the "interior part" of the "standard deviation of the"
4780 C gamma-dependent Gaussian lobe in t_c.
4781         sigtc=3*polthet(3,it)
4782         do j=2,1,-1
4783           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4784         enddo
4785         sigtc=sig*sigtc
4786 C Set the parameters of both Gaussian lobes of the distribution.
4787 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4788         fac=sig*sig+sigc0(it)
4789         sigcsq=fac+fac
4790         sigc=1.0D0/sigcsq
4791 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4792         sigsqtc=-4.0D0*sigcsq*sigtc
4793 c       print *,i,sig,sigtc,sigsqtc
4794 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4795         sigtc=-sigtc/(fac*fac)
4796 C Following variable is sigma(t_c)**(-2)
4797         sigcsq=sigcsq*sigcsq
4798         sig0i=sig0(it)
4799         sig0inv=1.0D0/sig0i**2
4800         delthec=thetai-thet_pred_mean
4801         delthe0=thetai-theta0i
4802         term1=-0.5D0*sigcsq*delthec*delthec
4803         term2=-0.5D0*sig0inv*delthe0*delthe0
4804 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4805 C NaNs in taking the logarithm. We extract the largest exponent which is added
4806 C to the energy (this being the log of the distribution) at the end of energy
4807 C term evaluation for this virtual-bond angle.
4808         if (term1.gt.term2) then
4809           termm=term1
4810           term2=dexp(term2-termm)
4811           term1=1.0d0
4812         else
4813           termm=term2
4814           term1=dexp(term1-termm)
4815           term2=1.0d0
4816         endif
4817 C The ratio between the gamma-independent and gamma-dependent lobes of
4818 C the distribution is a Gaussian function of thet_pred_mean too.
4819         diffak=gthet(2,it)-thet_pred_mean
4820         ratak=diffak/gthet(3,it)**2
4821         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4822 C Let's differentiate it in thet_pred_mean NOW.
4823         aktc=ak*ratak
4824 C Now put together the distribution terms to make complete distribution.
4825         termexp=term1+ak*term2
4826         termpre=sigc+ak*sig0i
4827 C Contribution of the bending energy from this theta is just the -log of
4828 C the sum of the contributions from the two lobes and the pre-exponential
4829 C factor. Simple enough, isn't it?
4830         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4831 C NOW the derivatives!!!
4832 C 6/6/97 Take into account the deformation.
4833         E_theta=(delthec*sigcsq*term1
4834      &       +ak*delthe0*sig0inv*term2)/termexp
4835         E_tc=((sigtc+aktc*sig0i)/termpre
4836      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4837      &       aktc*term2)/termexp)
4838       return
4839       end
4840 c-----------------------------------------------------------------------------
4841       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4842       implicit real*8 (a-h,o-z)
4843       include 'DIMENSIONS'
4844       include 'COMMON.LOCAL'
4845       include 'COMMON.IOUNITS'
4846       common /calcthet/ term1,term2,termm,diffak,ratak,
4847      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4848      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4849       delthec=thetai-thet_pred_mean
4850       delthe0=thetai-theta0i
4851 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4852       t3 = thetai-thet_pred_mean
4853       t6 = t3**2
4854       t9 = term1
4855       t12 = t3*sigcsq
4856       t14 = t12+t6*sigsqtc
4857       t16 = 1.0d0
4858       t21 = thetai-theta0i
4859       t23 = t21**2
4860       t26 = term2
4861       t27 = t21*t26
4862       t32 = termexp
4863       t40 = t32**2
4864       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4865      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4866      & *(-t12*t9-ak*sig0inv*t27)
4867       return
4868       end
4869 #else
4870 C--------------------------------------------------------------------------
4871       subroutine ebend(etheta)
4872 C
4873 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4874 C angles gamma and its derivatives in consecutive thetas and gammas.
4875 C ab initio-derived potentials from
4876 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4877 C
4878       implicit real*8 (a-h,o-z)
4879       include 'DIMENSIONS'
4880       include 'COMMON.LOCAL'
4881       include 'COMMON.GEO'
4882       include 'COMMON.INTERACT'
4883       include 'COMMON.DERIV'
4884       include 'COMMON.VAR'
4885       include 'COMMON.CHAIN'
4886       include 'COMMON.IOUNITS'
4887       include 'COMMON.NAMES'
4888       include 'COMMON.FFIELD'
4889       include 'COMMON.CONTROL'
4890       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4891      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4892      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4893      & sinph1ph2(maxdouble,maxdouble)
4894       logical lprn /.false./, lprn1 /.false./
4895       etheta=0.0D0
4896 c      write (iout,*) "EBEND ithet_start",ithet_start,
4897 c     &     " ithet_end",ithet_end
4898       do i=ithet_start,ithet_end
4899         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4900      &(itype(i).eq.ntyp1)) cycle
4901         dethetai=0.0d0
4902         dephii=0.0d0
4903         dephii1=0.0d0
4904         theti2=0.5d0*theta(i)
4905         ityp2=ithetyp(itype(i-1))
4906         do k=1,nntheterm
4907           coskt(k)=dcos(k*theti2)
4908           sinkt(k)=dsin(k*theti2)
4909         enddo
4910 C        if (i.gt.3) then
4911         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4912 #ifdef OSF
4913           phii=phi(i)
4914           if (phii.ne.phii) phii=150.0
4915 #else
4916           phii=phi(i)
4917 #endif
4918           ityp1=ithetyp(itype(i-2))
4919           do k=1,nsingle
4920             cosph1(k)=dcos(k*phii)
4921             sinph1(k)=dsin(k*phii)
4922           enddo
4923         else
4924           phii=0.0d0
4925           ityp1=ithetyp(itype(i-2))
4926           do k=1,nsingle
4927             cosph1(k)=0.0d0
4928             sinph1(k)=0.0d0
4929           enddo
4930         endif
4931         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4932 #ifdef OSF
4933           phii1=phi(i+1)
4934           if (phii1.ne.phii1) phii1=150.0
4935           phii1=pinorm(phii1)
4936 #else
4937           phii1=phi(i+1)
4938 #endif
4939           ityp3=ithetyp(itype(i))
4940           do k=1,nsingle
4941             cosph2(k)=dcos(k*phii1)
4942             sinph2(k)=dsin(k*phii1)
4943           enddo
4944         else
4945           phii1=0.0d0
4946           ityp3=ithetyp(itype(i))
4947           do k=1,nsingle
4948             cosph2(k)=0.0d0
4949             sinph2(k)=0.0d0
4950           enddo
4951         endif
4952         ethetai=aa0thet(ityp1,ityp2,ityp3)
4953         do k=1,ndouble
4954           do l=1,k-1
4955             ccl=cosph1(l)*cosph2(k-l)
4956             ssl=sinph1(l)*sinph2(k-l)
4957             scl=sinph1(l)*cosph2(k-l)
4958             csl=cosph1(l)*sinph2(k-l)
4959             cosph1ph2(l,k)=ccl-ssl
4960             cosph1ph2(k,l)=ccl+ssl
4961             sinph1ph2(l,k)=scl+csl
4962             sinph1ph2(k,l)=scl-csl
4963           enddo
4964         enddo
4965         if (lprn) then
4966         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4967      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4968         write (iout,*) "coskt and sinkt"
4969         do k=1,nntheterm
4970           write (iout,*) k,coskt(k),sinkt(k)
4971         enddo
4972         endif
4973         do k=1,ntheterm
4974           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4975           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4976      &      *coskt(k)
4977           if (lprn)
4978      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4979      &     " ethetai",ethetai
4980         enddo
4981         if (lprn) then
4982         write (iout,*) "cosph and sinph"
4983         do k=1,nsingle
4984           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4985         enddo
4986         write (iout,*) "cosph1ph2 and sinph2ph2"
4987         do k=2,ndouble
4988           do l=1,k-1
4989             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4990      &         sinph1ph2(l,k),sinph1ph2(k,l)
4991           enddo
4992         enddo
4993         write(iout,*) "ethetai",ethetai
4994         endif
4995         do m=1,ntheterm2
4996           do k=1,nsingle
4997             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4998      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4999      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
5000      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
5001             ethetai=ethetai+sinkt(m)*aux
5002             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5003             dephii=dephii+k*sinkt(m)*(
5004      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
5005      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
5006             dephii1=dephii1+k*sinkt(m)*(
5007      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
5008      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
5009             if (lprn)
5010      &      write (iout,*) "m",m," k",k," bbthet",
5011      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
5012      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
5013      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5014      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5015           enddo
5016         enddo
5017         if (lprn)
5018      &  write(iout,*) "ethetai",ethetai
5019         do m=1,ntheterm3
5020           do k=2,ndouble
5021             do l=1,k-1
5022               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5023      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5024      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5025      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5026               ethetai=ethetai+sinkt(m)*aux
5027               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5028               dephii=dephii+l*sinkt(m)*(
5029      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5030      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5031      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5032      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5033               dephii1=dephii1+(k-l)*sinkt(m)*(
5034      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5035      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5036      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5037      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5038               if (lprn) then
5039               write (iout,*) "m",m," k",k," l",l," ffthet",
5040      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5041      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5042      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5043      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5044               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5045      &            cosph1ph2(k,l)*sinkt(m),
5046      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5047               endif
5048             enddo
5049           enddo
5050         enddo
5051 10      continue
5052 c        lprn1=.true.
5053         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
5054      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
5055      &   phii1*rad2deg,ethetai
5056 c        lprn1=.false.
5057         etheta=etheta+ethetai
5058         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5059      &      'ebend',i,ethetai
5060         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5061         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5062         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5063       enddo
5064       return
5065       end
5066 #endif
5067 #ifdef CRYST_SC
5068 c-----------------------------------------------------------------------------
5069       subroutine esc(escloc)
5070 C Calculate the local energy of a side chain and its derivatives in the
5071 C corresponding virtual-bond valence angles THETA and the spherical angles
5072 C ALPHA and OMEGA.
5073       implicit real*8 (a-h,o-z)
5074       include 'DIMENSIONS'
5075       include 'COMMON.GEO'
5076       include 'COMMON.LOCAL'
5077       include 'COMMON.VAR'
5078       include 'COMMON.INTERACT'
5079       include 'COMMON.DERIV'
5080       include 'COMMON.CHAIN'
5081       include 'COMMON.IOUNITS'
5082       include 'COMMON.NAMES'
5083       include 'COMMON.FFIELD'
5084       include 'COMMON.CONTROL'
5085       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5086      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5087       common /sccalc/ time11,time12,time112,theti,it,nlobit
5088       delta=0.02d0*pi
5089       escloc=0.0D0
5090 c     write (iout,'(a)') 'ESC'
5091       do i=loc_start,loc_end
5092         it=itype(i)
5093         if (it.eq.10) goto 1
5094         nlobit=nlob(it)
5095 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5096 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5097         theti=theta(i+1)-pipol
5098         x(1)=dtan(theti)
5099         x(2)=alph(i)
5100         x(3)=omeg(i)
5101
5102         if (x(2).gt.pi-delta) then
5103           xtemp(1)=x(1)
5104           xtemp(2)=pi-delta
5105           xtemp(3)=x(3)
5106           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5107           xtemp(2)=pi
5108           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5109           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5110      &        escloci,dersc(2))
5111           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5112      &        ddersc0(1),dersc(1))
5113           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5114      &        ddersc0(3),dersc(3))
5115           xtemp(2)=pi-delta
5116           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5117           xtemp(2)=pi
5118           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5119           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5120      &            dersc0(2),esclocbi,dersc02)
5121           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5122      &            dersc12,dersc01)
5123           call splinthet(x(2),0.5d0*delta,ss,ssd)
5124           dersc0(1)=dersc01
5125           dersc0(2)=dersc02
5126           dersc0(3)=0.0d0
5127           do k=1,3
5128             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5129           enddo
5130           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5131 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5132 c    &             esclocbi,ss,ssd
5133           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5134 c         escloci=esclocbi
5135 c         write (iout,*) escloci
5136         else if (x(2).lt.delta) then
5137           xtemp(1)=x(1)
5138           xtemp(2)=delta
5139           xtemp(3)=x(3)
5140           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5141           xtemp(2)=0.0d0
5142           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5143           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5144      &        escloci,dersc(2))
5145           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5146      &        ddersc0(1),dersc(1))
5147           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5148      &        ddersc0(3),dersc(3))
5149           xtemp(2)=delta
5150           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5151           xtemp(2)=0.0d0
5152           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5153           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5154      &            dersc0(2),esclocbi,dersc02)
5155           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5156      &            dersc12,dersc01)
5157           dersc0(1)=dersc01
5158           dersc0(2)=dersc02
5159           dersc0(3)=0.0d0
5160           call splinthet(x(2),0.5d0*delta,ss,ssd)
5161           do k=1,3
5162             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5163           enddo
5164           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5165 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5166 c    &             esclocbi,ss,ssd
5167           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5168 c         write (iout,*) escloci
5169         else
5170           call enesc(x,escloci,dersc,ddummy,.false.)
5171         endif
5172
5173         escloc=escloc+escloci
5174         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5175      &     'escloc',i,escloci
5176 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5177
5178         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5179      &   wscloc*dersc(1)
5180         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5181         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5182     1   continue
5183       enddo
5184       return
5185       end
5186 C---------------------------------------------------------------------------
5187       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5188       implicit real*8 (a-h,o-z)
5189       include 'DIMENSIONS'
5190       include 'COMMON.GEO'
5191       include 'COMMON.LOCAL'
5192       include 'COMMON.IOUNITS'
5193       common /sccalc/ time11,time12,time112,theti,it,nlobit
5194       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5195       double precision contr(maxlob,-1:1)
5196       logical mixed
5197 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5198         escloc_i=0.0D0
5199         do j=1,3
5200           dersc(j)=0.0D0
5201           if (mixed) ddersc(j)=0.0d0
5202         enddo
5203         x3=x(3)
5204
5205 C Because of periodicity of the dependence of the SC energy in omega we have
5206 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5207 C To avoid underflows, first compute & store the exponents.
5208
5209         do iii=-1,1
5210
5211           x(3)=x3+iii*dwapi
5212
5213           do j=1,nlobit
5214             do k=1,3
5215               z(k)=x(k)-censc(k,j,it)
5216             enddo
5217             do k=1,3
5218               Axk=0.0D0
5219               do l=1,3
5220                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5221               enddo
5222               Ax(k,j,iii)=Axk
5223             enddo
5224             expfac=0.0D0
5225             do k=1,3
5226               expfac=expfac+Ax(k,j,iii)*z(k)
5227             enddo
5228             contr(j,iii)=expfac
5229           enddo ! j
5230
5231         enddo ! iii
5232
5233         x(3)=x3
5234 C As in the case of ebend, we want to avoid underflows in exponentiation and
5235 C subsequent NaNs and INFs in energy calculation.
5236 C Find the largest exponent
5237         emin=contr(1,-1)
5238         do iii=-1,1
5239           do j=1,nlobit
5240             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5241           enddo
5242         enddo
5243         emin=0.5D0*emin
5244 cd      print *,'it=',it,' emin=',emin
5245
5246 C Compute the contribution to SC energy and derivatives
5247         do iii=-1,1
5248
5249           do j=1,nlobit
5250 #ifdef OSF
5251             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5252             if(adexp.ne.adexp) adexp=1.0
5253             expfac=dexp(adexp)
5254 #else
5255             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5256 #endif
5257 cd          print *,'j=',j,' expfac=',expfac
5258             escloc_i=escloc_i+expfac
5259             do k=1,3
5260               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5261             enddo
5262             if (mixed) then
5263               do k=1,3,2
5264                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5265      &            +gaussc(k,2,j,it))*expfac
5266               enddo
5267             endif
5268           enddo
5269
5270         enddo ! iii
5271
5272         dersc(1)=dersc(1)/cos(theti)**2
5273         ddersc(1)=ddersc(1)/cos(theti)**2
5274         ddersc(3)=ddersc(3)
5275
5276         escloci=-(dlog(escloc_i)-emin)
5277         do j=1,3
5278           dersc(j)=dersc(j)/escloc_i
5279         enddo
5280         if (mixed) then
5281           do j=1,3,2
5282             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5283           enddo
5284         endif
5285       return
5286       end
5287 C------------------------------------------------------------------------------
5288       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5289       implicit real*8 (a-h,o-z)
5290       include 'DIMENSIONS'
5291       include 'COMMON.GEO'
5292       include 'COMMON.LOCAL'
5293       include 'COMMON.IOUNITS'
5294       common /sccalc/ time11,time12,time112,theti,it,nlobit
5295       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5296       double precision contr(maxlob)
5297       logical mixed
5298
5299       escloc_i=0.0D0
5300
5301       do j=1,3
5302         dersc(j)=0.0D0
5303       enddo
5304
5305       do j=1,nlobit
5306         do k=1,2
5307           z(k)=x(k)-censc(k,j,it)
5308         enddo
5309         z(3)=dwapi
5310         do k=1,3
5311           Axk=0.0D0
5312           do l=1,3
5313             Axk=Axk+gaussc(l,k,j,it)*z(l)
5314           enddo
5315           Ax(k,j)=Axk
5316         enddo
5317         expfac=0.0D0
5318         do k=1,3
5319           expfac=expfac+Ax(k,j)*z(k)
5320         enddo
5321         contr(j)=expfac
5322       enddo ! j
5323
5324 C As in the case of ebend, we want to avoid underflows in exponentiation and
5325 C subsequent NaNs and INFs in energy calculation.
5326 C Find the largest exponent
5327       emin=contr(1)
5328       do j=1,nlobit
5329         if (emin.gt.contr(j)) emin=contr(j)
5330       enddo
5331       emin=0.5D0*emin
5332
5333 C Compute the contribution to SC energy and derivatives
5334
5335       dersc12=0.0d0
5336       do j=1,nlobit
5337         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5338         escloc_i=escloc_i+expfac
5339         do k=1,2
5340           dersc(k)=dersc(k)+Ax(k,j)*expfac
5341         enddo
5342         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5343      &            +gaussc(1,2,j,it))*expfac
5344         dersc(3)=0.0d0
5345       enddo
5346
5347       dersc(1)=dersc(1)/cos(theti)**2
5348       dersc12=dersc12/cos(theti)**2
5349       escloci=-(dlog(escloc_i)-emin)
5350       do j=1,2
5351         dersc(j)=dersc(j)/escloc_i
5352       enddo
5353       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5354       return
5355       end
5356 #else
5357 c----------------------------------------------------------------------------------
5358       subroutine esc(escloc)
5359 C Calculate the local energy of a side chain and its derivatives in the
5360 C corresponding virtual-bond valence angles THETA and the spherical angles
5361 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5362 C added by Urszula Kozlowska. 07/11/2007
5363 C
5364       implicit real*8 (a-h,o-z)
5365       include 'DIMENSIONS'
5366       include 'COMMON.GEO'
5367       include 'COMMON.LOCAL'
5368       include 'COMMON.VAR'
5369       include 'COMMON.SCROT'
5370       include 'COMMON.INTERACT'
5371       include 'COMMON.DERIV'
5372       include 'COMMON.CHAIN'
5373       include 'COMMON.IOUNITS'
5374       include 'COMMON.NAMES'
5375       include 'COMMON.FFIELD'
5376       include 'COMMON.CONTROL'
5377       include 'COMMON.VECTORS'
5378       double precision x_prime(3),y_prime(3),z_prime(3)
5379      &    , sumene,dsc_i,dp2_i,x(65),
5380      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5381      &    de_dxx,de_dyy,de_dzz,de_dt
5382       double precision s1_t,s1_6_t,s2_t,s2_6_t
5383       double precision
5384      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5385      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5386      & dt_dCi(3),dt_dCi1(3)
5387       common /sccalc/ time11,time12,time112,theti,it,nlobit
5388       delta=0.02d0*pi
5389       escloc=0.0D0
5390 c      write(iout,*) "ESC: loc_start",loc_start," loc_end",loc_end
5391       do i=loc_start,loc_end
5392         costtab(i+1) =dcos(theta(i+1))
5393         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5394         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5395         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5396         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5397         cosfac=dsqrt(cosfac2)
5398         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5399         sinfac=dsqrt(sinfac2)
5400         it=itype(i)
5401         if (it.eq.10) goto 1
5402 c
5403 C  Compute the axes of tghe local cartesian coordinates system; store in
5404 c   x_prime, y_prime and z_prime
5405 c
5406         do j=1,3
5407           x_prime(j) = 0.00
5408           y_prime(j) = 0.00
5409           z_prime(j) = 0.00
5410         enddo
5411 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5412 C     &   dc_norm(3,i+nres)
5413         do j = 1,3
5414           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5415           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5416         enddo
5417         do j = 1,3
5418           z_prime(j) = -uz(j,i-1)
5419         enddo
5420 c       write (2,*) "i",i
5421 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5422 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5423 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5424 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5425 c      & " xy",scalar(x_prime(1),y_prime(1)),
5426 c      & " xz",scalar(x_prime(1),z_prime(1)),
5427 c      & " yy",scalar(y_prime(1),y_prime(1)),
5428 c      & " yz",scalar(y_prime(1),z_prime(1)),
5429 c      & " zz",scalar(z_prime(1),z_prime(1))
5430 c
5431 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5432 C to local coordinate system. Store in xx, yy, zz.
5433 c
5434         xx=0.0d0
5435         yy=0.0d0
5436         zz=0.0d0
5437         do j = 1,3
5438           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5439           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5440           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5441         enddo
5442
5443         xxtab(i)=xx
5444         yytab(i)=yy
5445         zztab(i)=zz
5446 C
5447 C Compute the energy of the ith side cbain
5448 C
5449 c        write (2,*) "xx",xx," yy",yy," zz",zz
5450         it=itype(i)
5451         do j = 1,65
5452           x(j) = sc_parmin(j,it)
5453         enddo
5454 #ifdef CHECK_COORD
5455 Cc diagnostics - remove later
5456         xx1 = dcos(alph(2))
5457         yy1 = dsin(alph(2))*dcos(omeg(2))
5458         zz1 = -dsin(alph(2))*dsin(omeg(2))
5459         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5460      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5461      &    xx1,yy1,zz1
5462 C,"  --- ", xx_w,yy_w,zz_w
5463 c end diagnostics
5464 #endif
5465         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5466      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5467      &   + x(10)*yy*zz
5468         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5469      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5470      & + x(20)*yy*zz
5471         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5472      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5473      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5474      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5475      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5476      &  +x(40)*xx*yy*zz
5477         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5478      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5479      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5480      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5481      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5482      &  +x(60)*xx*yy*zz
5483         dsc_i   = 0.743d0+x(61)
5484         dp2_i   = 1.9d0+x(62)
5485         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5486      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5487         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5488      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5489         s1=(1+x(63))/(0.1d0 + dscp1)
5490         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5491         s2=(1+x(65))/(0.1d0 + dscp2)
5492         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5493         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5494      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5495 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5496 c     &   sumene4,
5497 c     &   dscp1,dscp2,sumene
5498 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5499         escloc = escloc + sumene
5500         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5501      &     'escloc',i,sumene
5502 #ifdef DEBUG
5503 C
5504 C This section to check the numerical derivatives of the energy of ith side
5505 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5506 C #define DEBUG in the code to turn it on.
5507 C
5508         write (2,*) "sumene               =",sumene
5509         aincr=1.0d-7
5510         xxsave=xx
5511         xx=xx+aincr
5512         write (2,*) xx,yy,zz
5513         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5514         de_dxx_num=(sumenep-sumene)/aincr
5515         xx=xxsave
5516         write (2,*) "xx+ sumene from enesc=",sumenep
5517         yysave=yy
5518         yy=yy+aincr
5519         write (2,*) xx,yy,zz
5520         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5521         de_dyy_num=(sumenep-sumene)/aincr
5522         yy=yysave
5523         write (2,*) "yy+ sumene from enesc=",sumenep
5524         zzsave=zz
5525         zz=zz+aincr
5526         write (2,*) xx,yy,zz
5527         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5528         de_dzz_num=(sumenep-sumene)/aincr
5529         zz=zzsave
5530         write (2,*) "zz+ sumene from enesc=",sumenep
5531         costsave=cost2tab(i+1)
5532         sintsave=sint2tab(i+1)
5533         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5534         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5535         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5536         de_dt_num=(sumenep-sumene)/aincr
5537         write (2,*) " t+ sumene from enesc=",sumenep
5538         cost2tab(i+1)=costsave
5539         sint2tab(i+1)=sintsave
5540 C End of diagnostics section.
5541 #endif
5542 C
5543 C Compute the gradient of esc
5544 C
5545         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5546         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5547         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5548         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5549         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5550         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5551         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5552         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5553         pom1=(sumene3*sint2tab(i+1)+sumene1)
5554      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5555         pom2=(sumene4*cost2tab(i+1)+sumene2)
5556      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5557         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5558         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5559      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5560      &  +x(40)*yy*zz
5561         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5562         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5563      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5564      &  +x(60)*yy*zz
5565         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5566      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5567      &        +(pom1+pom2)*pom_dx
5568 #ifdef DEBUG
5569         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5570 #endif
5571 C
5572         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5573         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5574      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5575      &  +x(40)*xx*zz
5576         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5577         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5578      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5579      &  +x(59)*zz**2 +x(60)*xx*zz
5580         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5581      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5582      &        +(pom1-pom2)*pom_dy
5583 #ifdef DEBUG
5584         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5585 #endif
5586 C
5587         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5588      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5589      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5590      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5591      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5592      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5593      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5594      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5595 #ifdef DEBUG
5596         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5597 #endif
5598 C
5599         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5600      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5601      &  +pom1*pom_dt1+pom2*pom_dt2
5602 #ifdef DEBUG
5603         write(2,*), "de_dt = ", de_dt,de_dt_num
5604 #endif
5605 c
5606 C
5607        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5608        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5609        cosfac2xx=cosfac2*xx
5610        sinfac2yy=sinfac2*yy
5611        do k = 1,3
5612          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5613      &      vbld_inv(i+1)
5614          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5615      &      vbld_inv(i)
5616          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5617          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5618 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5619 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5620 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5621 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5622          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5623          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5624          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5625          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5626          dZZ_Ci1(k)=0.0d0
5627          dZZ_Ci(k)=0.0d0
5628          do j=1,3
5629            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5630            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5631          enddo
5632
5633          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5634          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5635          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5636 c
5637          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5638          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5639        enddo
5640
5641        do k=1,3
5642          dXX_Ctab(k,i)=dXX_Ci(k)
5643          dXX_C1tab(k,i)=dXX_Ci1(k)
5644          dYY_Ctab(k,i)=dYY_Ci(k)
5645          dYY_C1tab(k,i)=dYY_Ci1(k)
5646          dZZ_Ctab(k,i)=dZZ_Ci(k)
5647          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5648          dXX_XYZtab(k,i)=dXX_XYZ(k)
5649          dYY_XYZtab(k,i)=dYY_XYZ(k)
5650          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5651        enddo
5652
5653        do k = 1,3
5654 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5655 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5656 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5657 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5658 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5659 c     &    dt_dci(k)
5660 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5661 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5662          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5663      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5664          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5665      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5666          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5667      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5668        enddo
5669 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5670 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5671
5672 C to check gradient call subroutine check_grad
5673
5674     1 continue
5675       enddo
5676       return
5677       end
5678 c------------------------------------------------------------------------------
5679       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5680       implicit none
5681       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5682      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5683       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5684      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5685      &   + x(10)*yy*zz
5686       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5687      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5688      & + x(20)*yy*zz
5689       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5690      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5691      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5692      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5693      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5694      &  +x(40)*xx*yy*zz
5695       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5696      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5697      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5698      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5699      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5700      &  +x(60)*xx*yy*zz
5701       dsc_i   = 0.743d0+x(61)
5702       dp2_i   = 1.9d0+x(62)
5703       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5704      &          *(xx*cost2+yy*sint2))
5705       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5706      &          *(xx*cost2-yy*sint2))
5707       s1=(1+x(63))/(0.1d0 + dscp1)
5708       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5709       s2=(1+x(65))/(0.1d0 + dscp2)
5710       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5711       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5712      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5713       enesc=sumene
5714       return
5715       end
5716 #endif
5717 c------------------------------------------------------------------------------
5718       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5719 C
5720 C This procedure calculates two-body contact function g(rij) and its derivative:
5721 C
5722 C           eps0ij                                     !       x < -1
5723 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5724 C            0                                         !       x > 1
5725 C
5726 C where x=(rij-r0ij)/delta
5727 C
5728 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5729 C
5730       implicit none
5731       double precision rij,r0ij,eps0ij,fcont,fprimcont
5732       double precision x,x2,x4,delta
5733 c     delta=0.02D0*r0ij
5734 c      delta=0.2D0*r0ij
5735       x=(rij-r0ij)/delta
5736       if (x.lt.-1.0D0) then
5737         fcont=eps0ij
5738         fprimcont=0.0D0
5739       else if (x.le.1.0D0) then
5740         x2=x*x
5741         x4=x2*x2
5742         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5743         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5744       else
5745         fcont=0.0D0
5746         fprimcont=0.0D0
5747       endif
5748       return
5749       end
5750 c------------------------------------------------------------------------------
5751       subroutine splinthet(theti,delta,ss,ssder)
5752       implicit real*8 (a-h,o-z)
5753       include 'DIMENSIONS'
5754       include 'COMMON.VAR'
5755       include 'COMMON.GEO'
5756       thetup=pi-delta
5757       thetlow=delta
5758       if (theti.gt.pipol) then
5759         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5760       else
5761         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5762         ssder=-ssder
5763       endif
5764       return
5765       end
5766 c------------------------------------------------------------------------------
5767       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5768       implicit none
5769       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5770       double precision ksi,ksi2,ksi3,a1,a2,a3
5771       a1=fprim0*delta/(f1-f0)
5772       a2=3.0d0-2.0d0*a1
5773       a3=a1-2.0d0
5774       ksi=(x-x0)/delta
5775       ksi2=ksi*ksi
5776       ksi3=ksi2*ksi
5777       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5778       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5779       return
5780       end
5781 c------------------------------------------------------------------------------
5782       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5783       implicit none
5784       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5785       double precision ksi,ksi2,ksi3,a1,a2,a3
5786       ksi=(x-x0)/delta
5787       ksi2=ksi*ksi
5788       ksi3=ksi2*ksi
5789       a1=fprim0x*delta
5790       a2=3*(f1x-f0x)-2*fprim0x*delta
5791       a3=fprim0x*delta-2*(f1x-f0x)
5792       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5793       return
5794       end
5795 C-----------------------------------------------------------------------------
5796 #ifdef CRYST_TOR
5797 C-----------------------------------------------------------------------------
5798       subroutine etor(etors,edihcnstr)
5799       implicit real*8 (a-h,o-z)
5800       include 'DIMENSIONS'
5801       include 'COMMON.VAR'
5802       include 'COMMON.GEO'
5803       include 'COMMON.LOCAL'
5804       include 'COMMON.TORSION'
5805       include 'COMMON.INTERACT'
5806       include 'COMMON.DERIV'
5807       include 'COMMON.CHAIN'
5808       include 'COMMON.NAMES'
5809       include 'COMMON.IOUNITS'
5810       include 'COMMON.FFIELD'
5811       include 'COMMON.TORCNSTR'
5812       include 'COMMON.CONTROL'
5813       logical lprn
5814 C Set lprn=.true. for debugging
5815       lprn=.false.
5816 c      lprn=.true.
5817       etors=0.0D0
5818       do i=iphi_start,iphi_end
5819       etors_ii=0.0D0
5820         itori=itortyp(itype(i-2))
5821         itori1=itortyp(itype(i-1))
5822         phii=phi(i)
5823         gloci=0.0D0
5824 C Proline-Proline pair is a special case...
5825         if (itori.eq.3 .and. itori1.eq.3) then
5826           if (phii.gt.-dwapi3) then
5827             cosphi=dcos(3*phii)
5828             fac=1.0D0/(1.0D0-cosphi)
5829             etorsi=v1(1,3,3)*fac
5830             etorsi=etorsi+etorsi
5831             etors=etors+etorsi-v1(1,3,3)
5832             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5833             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5834           endif
5835           do j=1,3
5836             v1ij=v1(j+1,itori,itori1)
5837             v2ij=v2(j+1,itori,itori1)
5838             cosphi=dcos(j*phii)
5839             sinphi=dsin(j*phii)
5840             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5841             if (energy_dec) etors_ii=etors_ii+
5842      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5843             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5844           enddo
5845         else
5846           do j=1,nterm_old
5847             v1ij=v1(j,itori,itori1)
5848             v2ij=v2(j,itori,itori1)
5849             cosphi=dcos(j*phii)
5850             sinphi=dsin(j*phii)
5851             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5852             if (energy_dec) etors_ii=etors_ii+
5853      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5854             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5855           enddo
5856         endif
5857         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5858      &        'etor',i,etors_ii
5859         if (lprn)
5860      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5861      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5862      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5863         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5864         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5865       enddo
5866 ! 6/20/98 - dihedral angle constraints
5867       edihcnstr=0.0d0
5868       do i=1,ndih_constr
5869         itori=idih_constr(i)
5870         phii=phi(itori)
5871         difi=phii-phi0(i)
5872         if (difi.gt.drange(i)) then
5873           difi=difi-drange(i)
5874           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5875           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5876         else if (difi.lt.-drange(i)) then
5877           difi=difi+drange(i)
5878           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5879           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5880         endif
5881 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5882 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5883       enddo
5884 !      write (iout,*) 'edihcnstr',edihcnstr
5885       return
5886       end
5887 c------------------------------------------------------------------------------
5888 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5889       subroutine e_modeller(ehomology_constr)
5890       ehomology_constr=0.0d0
5891       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5892       return
5893       end
5894 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5895
5896 c------------------------------------------------------------------------------
5897       subroutine etor_d(etors_d)
5898       etors_d=0.0d0
5899       return
5900       end
5901 c----------------------------------------------------------------------------
5902 #else
5903       subroutine etor(etors,edihcnstr)
5904       implicit real*8 (a-h,o-z)
5905       include 'DIMENSIONS'
5906       include 'COMMON.VAR'
5907       include 'COMMON.GEO'
5908       include 'COMMON.LOCAL'
5909       include 'COMMON.TORSION'
5910       include 'COMMON.INTERACT'
5911       include 'COMMON.DERIV'
5912       include 'COMMON.CHAIN'
5913       include 'COMMON.NAMES'
5914       include 'COMMON.IOUNITS'
5915       include 'COMMON.FFIELD'
5916       include 'COMMON.TORCNSTR'
5917       include 'COMMON.CONTROL'
5918       logical lprn
5919 C Set lprn=.true. for debugging
5920       lprn=.false.
5921 c     lprn=.true.
5922       etors=0.0D0
5923       do i=iphi_start,iphi_end
5924       etors_ii=0.0D0
5925         itori=itortyp(itype(i-2))
5926         itori1=itortyp(itype(i-1))
5927         phii=phi(i)
5928         gloci=0.0D0
5929 C Regular cosine and sine terms
5930         do j=1,nterm(itori,itori1)
5931           v1ij=v1(j,itori,itori1)
5932           v2ij=v2(j,itori,itori1)
5933           cosphi=dcos(j*phii)
5934           sinphi=dsin(j*phii)
5935           etors=etors+v1ij*cosphi+v2ij*sinphi
5936           if (energy_dec) etors_ii=etors_ii+
5937      &                v1ij*cosphi+v2ij*sinphi
5938           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5939         enddo
5940 C Lorentz terms
5941 C                         v1
5942 C  E = SUM ----------------------------------- - v1
5943 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5944 C
5945         cosphi=dcos(0.5d0*phii)
5946         sinphi=dsin(0.5d0*phii)
5947         do j=1,nlor(itori,itori1)
5948           vl1ij=vlor1(j,itori,itori1)
5949           vl2ij=vlor2(j,itori,itori1)
5950           vl3ij=vlor3(j,itori,itori1)
5951           pom=vl2ij*cosphi+vl3ij*sinphi
5952           pom1=1.0d0/(pom*pom+1.0d0)
5953           etors=etors+vl1ij*pom1
5954           if (energy_dec) etors_ii=etors_ii+
5955      &                vl1ij*pom1
5956           pom=-pom*pom1*pom1
5957           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5958         enddo
5959 C Subtract the constant term
5960         etors=etors-v0(itori,itori1)
5961           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5962      &         'etor',i,etors_ii-v0(itori,itori1)
5963         if (lprn)
5964      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5965      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5966      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5967         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5968 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5969       enddo
5970 ! 6/20/98 - dihedral angle constraints
5971       edihcnstr=0.0d0
5972 c      do i=1,ndih_constr
5973       do i=idihconstr_start,idihconstr_end
5974         itori=idih_constr(i)
5975         phii=phi(itori)
5976         difi=pinorm(phii-phi0(i))
5977         if (difi.gt.drange(i)) then
5978           difi=difi-drange(i)
5979           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5980           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5981         else if (difi.lt.-drange(i)) then
5982           difi=difi+drange(i)
5983           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5984           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5985         else
5986           difi=0.0
5987         endif
5988 c        write (iout,*) "gloci", gloc(i-3,icg)
5989 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5990 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5991 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5992       enddo
5993 cd       write (iout,*) 'edihcnstr',edihcnstr
5994       return
5995       end
5996 c----------------------------------------------------------------------------
5997 c MODELLER restraint function
5998       subroutine e_modeller(ehomology_constr)
5999       implicit real*8 (a-h,o-z)
6000       include 'DIMENSIONS'
6001
6002       integer nnn, i, j, k, ki, irec, l
6003       integer katy, odleglosci, test7
6004       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
6005       real*8 Eval,Erot
6006       real*8 distance(max_template),distancek(max_template),
6007      &    min_odl,godl(max_template),dih_diff(max_template)
6008
6009 c
6010 c     FP - 30/10/2014 Temporary specifications for homology restraints
6011 c
6012       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6013      &                 sgtheta
6014       double precision, dimension (maxres) :: guscdiff,usc_diff
6015       double precision, dimension (max_template) ::
6016      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6017      &           theta_diff
6018 c
6019
6020       include 'COMMON.SBRIDGE'
6021       include 'COMMON.CHAIN'
6022       include 'COMMON.GEO'
6023       include 'COMMON.DERIV'
6024       include 'COMMON.LOCAL'
6025       include 'COMMON.INTERACT'
6026       include 'COMMON.VAR'
6027       include 'COMMON.IOUNITS'
6028       include 'COMMON.MD'
6029       include 'COMMON.CONTROL'
6030 c
6031 c     From subroutine Econstr_back
6032 c
6033       include 'COMMON.NAMES'
6034       include 'COMMON.TIME1'
6035 c
6036
6037
6038       do i=1,max_template
6039         distancek(i)=9999999.9
6040       enddo
6041
6042
6043       odleg=0.0d0
6044
6045 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6046 c function)
6047 C AL 5/2/14 - Introduce list of restraints
6048 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6049 #ifdef DEBUG
6050       write(iout,*) "------- dist restrs start -------"
6051 #endif
6052       do ii = link_start_homo,link_end_homo
6053          i = ires_homo(ii)
6054          j = jres_homo(ii)
6055          dij=dist(i,j)
6056 c        write (iout,*) "dij(",i,j,") =",dij
6057          nexl=0
6058          do k=1,constr_homology
6059 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
6060            if(.not.l_homo(k,ii)) then
6061              nexl=nexl+1
6062              cycle
6063            endif
6064            distance(k)=odl(k,ii)-dij
6065 c          write (iout,*) "distance(",k,") =",distance(k)
6066 c
6067 c          For Gaussian-type Urestr
6068 c
6069            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6070 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6071 c          write (iout,*) "distancek(",k,") =",distancek(k)
6072 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6073 c
6074 c          For Lorentzian-type Urestr
6075 c
6076            if (waga_dist.lt.0.0d0) then
6077               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6078               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6079      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
6080            endif
6081          enddo
6082 c         write (iout,*) "distance: ii",ii," nexl",nexl
6083
6084
6085 c         min_odl=minval(distancek)
6086          do kk=1,constr_homology
6087           if(l_homo(kk,ii)) then
6088             min_odl=distancek(kk)
6089             exit
6090           endif
6091          enddo
6092          do kk=1,constr_homology
6093           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
6094      &              min_odl=distancek(kk)
6095          enddo
6096 c        write (iout,* )"min_odl",min_odl
6097 #ifdef DEBUG
6098          write (iout,*) "ij dij",i,j,dij
6099          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6100          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6101          write (iout,* )"min_odl",min_odl
6102 #endif
6103 #ifdef OLDRESTR
6104          odleg2=0.0d0
6105 #else
6106          if (waga_dist.ge.0.0d0) then
6107            odleg2=nexl
6108          else
6109            odleg2=0.0d0
6110          endif
6111 #endif
6112          do k=1,constr_homology
6113 c Nie wiem po co to liczycie jeszcze raz!
6114 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6115 c     &              (2*(sigma_odl(i,j,k))**2))
6116            if(.not.l_homo(k,ii)) cycle
6117            if (waga_dist.ge.0.0d0) then
6118 c
6119 c          For Gaussian-type Urestr
6120 c
6121             godl(k)=dexp(-distancek(k)+min_odl)
6122             odleg2=odleg2+godl(k)
6123 c
6124 c          For Lorentzian-type Urestr
6125 c
6126            else
6127             odleg2=odleg2+distancek(k)
6128            endif
6129
6130 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6131 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6132 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6133 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6134
6135          enddo
6136 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6137 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6138 #ifdef DEBUG
6139          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6140          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6141 #endif
6142            if (waga_dist.ge.0.0d0) then
6143 c
6144 c          For Gaussian-type Urestr
6145 c
6146               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6147 c
6148 c          For Lorentzian-type Urestr
6149 c
6150            else
6151               odleg=odleg+odleg2/constr_homology
6152            endif
6153 c
6154 c        write (iout,*) "odleg",odleg ! sum of -ln-s
6155 c Gradient
6156 c
6157 c          For Gaussian-type Urestr
6158 c
6159          if (waga_dist.ge.0.0d0) sum_godl=odleg2
6160          sum_sgodl=0.0d0
6161          do k=1,constr_homology
6162 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6163 c     &           *waga_dist)+min_odl
6164 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6165 c
6166          if(.not.l_homo(k,ii)) cycle
6167          if (waga_dist.ge.0.0d0) then
6168 c          For Gaussian-type Urestr
6169 c
6170            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6171 c
6172 c          For Lorentzian-type Urestr
6173 c
6174          else
6175            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
6176      &           sigma_odlir(k,ii)**2)**2)
6177          endif
6178            sum_sgodl=sum_sgodl+sgodl
6179
6180 c            sgodl2=sgodl2+sgodl
6181 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6182 c      write(iout,*) "constr_homology=",constr_homology
6183 c      write(iout,*) i, j, k, "TEST K"
6184          enddo
6185          if (waga_dist.ge.0.0d0) then
6186 c
6187 c          For Gaussian-type Urestr
6188 c
6189             grad_odl3=waga_homology(iset)*waga_dist
6190      &                *sum_sgodl/(sum_godl*dij)
6191 c
6192 c          For Lorentzian-type Urestr
6193 c
6194          else
6195 c Original grad expr modified by analogy w Gaussian-type Urestr grad
6196 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
6197             grad_odl3=-waga_homology(iset)*waga_dist*
6198      &                sum_sgodl/(constr_homology*dij)
6199          endif
6200 c
6201 c        grad_odl3=sum_sgodl/(sum_godl*dij)
6202
6203
6204 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6205 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6206 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6207
6208 ccc      write(iout,*) godl, sgodl, grad_odl3
6209
6210 c          grad_odl=grad_odl+grad_odl3
6211
6212          do jik=1,3
6213             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
6214 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6215 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6216 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6217             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
6218             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
6219 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6220 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6221 c         if (i.eq.25.and.j.eq.27) then
6222 c         write(iout,*) "jik",jik,"i",i,"j",j
6223 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
6224 c         write(iout,*) "grad_odl3",grad_odl3
6225 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
6226 c         write(iout,*) "ggodl",ggodl
6227 c         write(iout,*) "ghpbc(",jik,i,")",
6228 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
6229 c     &                 ghpbc(jik,j)
6230 c         endif
6231          enddo
6232 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
6233 ccc     & dLOG(odleg2),"-odleg=", -odleg
6234
6235       enddo ! ii-loop for dist
6236 #ifdef DEBUG
6237       write(iout,*) "------- dist restrs end -------"
6238 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
6239 c    &     waga_d.eq.1.0d0) call sum_gradient
6240 #endif
6241 c Pseudo-energy and gradient from dihedral-angle restraints from
6242 c homology templates
6243 c      write (iout,*) "End of distance loop"
6244 c      call flush(iout)
6245       kat=0.0d0
6246 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6247 #ifdef DEBUG
6248       write(iout,*) "------- dih restrs start -------"
6249       do i=idihconstr_start_homo,idihconstr_end_homo
6250         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
6251       enddo
6252 #endif
6253       do i=idihconstr_start_homo,idihconstr_end_homo
6254 c        betai=beta(i,i+1,i+2,i+3)
6255         betai = phi(i)
6256 c       write (iout,*) "betai =",betai
6257         kat2=0.0d0
6258         do k=1,constr_homology
6259           dih_diff(k)=pinorm(dih(k,i)-betai)
6260 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
6261 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6262 c     &                                   -(6.28318-dih_diff(i,k))
6263 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6264 c     &                                   6.28318+dih_diff(i,k)
6265 #ifdef OLD_DIHED
6266           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
6267 #else
6268           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
6269 #endif
6270 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
6271           gdih(k)=dexp(kat3)
6272           kat2=kat2+gdih(k)
6273 c          write(iout,*) "i",i," k",k," sigma",sigma_dih(k,i),
6274 c     &     " kat2=", kat2, "gdih=",gdih(k)
6275         enddo
6276 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
6277 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
6278 #ifdef DEBUG
6279         write (iout,*) "i",i," betai",betai," kat2",kat2
6280         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6281 #endif
6282         if (kat2.le.1.0d-14) cycle
6283         kat=kat-dLOG(kat2/constr_homology)
6284 c       write (iout,*) "kat",kat ! sum of -ln-s
6285
6286 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6287 ccc     & dLOG(kat2), "-kat=", -kat
6288
6289 c ----------------------------------------------------------------------
6290 c Gradient
6291 c ----------------------------------------------------------------------
6292
6293         sum_gdih=kat2
6294         sum_sgdih=0.0d0
6295         do k=1,constr_homology
6296 #ifdef OLD_DIHED
6297           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
6298 #else
6299           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
6300 #endif
6301 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
6302           sum_sgdih=sum_sgdih+sgdih
6303         enddo
6304 c       grad_dih3=sum_sgdih/sum_gdih
6305         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
6306
6307 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6308 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6309 ccc     & gloc(nphi+i-3,icg)
6310         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
6311 c        if (i.eq.25) then
6312 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
6313 c        endif
6314 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6315 ccc     & gloc(nphi+i-3,icg)
6316
6317       enddo ! i-loop for dih
6318 #ifdef DEBUG
6319       write(iout,*) "------- dih restrs end -------"
6320 #endif
6321
6322 c Pseudo-energy and gradient for theta angle restraints from
6323 c homology templates
6324 c FP 01/15 - inserted from econstr_local_test.F, loop structure
6325 c adapted
6326
6327 c
6328 c     For constr_homology reference structures (FP)
6329 c
6330 c     Uconst_back_tot=0.0d0
6331       Eval=0.0d0
6332       Erot=0.0d0
6333 c     Econstr_back legacy
6334       do i=1,nres
6335 c     do i=ithet_start,ithet_end
6336        dutheta(i)=0.0d0
6337 c     enddo
6338 c     do i=loc_start,loc_end
6339         do j=1,3
6340           duscdiff(j,i)=0.0d0
6341           duscdiffx(j,i)=0.0d0
6342         enddo
6343       enddo
6344 c
6345 c     do iref=1,nref
6346 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
6347 c     write (iout,*) "waga_theta",waga_theta
6348       if (waga_theta.gt.0.0d0) then
6349 #ifdef DEBUG
6350       write (iout,*) "usampl",usampl
6351       write(iout,*) "------- theta restrs start -------"
6352 c     do i=ithet_start,ithet_end
6353 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
6354 c     enddo
6355 #endif
6356 c     write (iout,*) "maxres",maxres,"nres",nres
6357
6358       do i=ithet_start,ithet_end
6359 c
6360 c     do i=1,nfrag_back
6361 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
6362 c
6363 c Deviation of theta angles wrt constr_homology ref structures
6364 c
6365         utheta_i=0.0d0 ! argument of Gaussian for single k
6366         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6367 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
6368 c       over residues in a fragment
6369 c       write (iout,*) "theta(",i,")=",theta(i)
6370         do k=1,constr_homology
6371 c
6372 c         dtheta_i=theta(j)-thetaref(j,iref)
6373 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
6374           theta_diff(k)=thetatpl(k,i)-theta(i)
6375 c
6376           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
6377 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
6378           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
6379           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
6380 c          write (iout,*) "i",i," k",k," sigma_theta",sigma_theta(k,i),
6381 c     &     " gtheta",gtheta(k)
6382 c         Gradient for single Gaussian restraint in subr Econstr_back
6383 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
6384 c
6385         enddo
6386 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
6387 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
6388
6389 c
6390 c         Gradient for multiple Gaussian restraint
6391         sum_gtheta=gutheta_i
6392         sum_sgtheta=0.0d0
6393         do k=1,constr_homology
6394 c        New generalized expr for multiple Gaussian from Econstr_back
6395          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
6396 c
6397 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
6398           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
6399         enddo
6400 c       Final value of gradient using same var as in Econstr_back
6401         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
6402      &      +sum_sgtheta/sum_gtheta*waga_theta
6403      &               *waga_homology(iset)
6404 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
6405 c     &               *waga_homology(iset)
6406 c       dutheta(i)=sum_sgtheta/sum_gtheta
6407 c
6408 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
6409         Eval=Eval-dLOG(gutheta_i/constr_homology)
6410 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
6411 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
6412 c       Uconst_back=Uconst_back+utheta(i)
6413       enddo ! (i-loop for theta)
6414 #ifdef DEBUG
6415       write(iout,*) "------- theta restrs end -------"
6416 #endif
6417       endif
6418 c
6419 c Deviation of local SC geometry
6420 c
6421 c Separation of two i-loops (instructed by AL - 11/3/2014)
6422 c
6423 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
6424 c     write (iout,*) "waga_d",waga_d
6425
6426 #ifdef DEBUG
6427       write(iout,*) "------- SC restrs start -------"
6428       write (iout,*) "Initial duscdiff,duscdiffx"
6429       do i=loc_start,loc_end
6430         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
6431      &                 (duscdiffx(jik,i),jik=1,3)
6432       enddo
6433 #endif
6434       do i=loc_start,loc_end
6435         usc_diff_i=0.0d0 ! argument of Gaussian for single k
6436         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6437 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
6438 c       write(iout,*) "xxtab, yytab, zztab"
6439 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
6440         do k=1,constr_homology
6441 c
6442           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6443 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
6444           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6445           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6446 c         write(iout,*) "dxx, dyy, dzz"
6447 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6448 c
6449           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
6450 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
6451 c         uscdiffk(k)=usc_diff(i)
6452           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
6453 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
6454 c     &       " guscdiff2",guscdiff2(k)
6455           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
6456 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
6457 c     &      xxref(j),yyref(j),zzref(j)
6458         enddo
6459 c
6460 c       Gradient
6461 c
6462 c       Generalized expression for multiple Gaussian acc to that for a single
6463 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
6464 c
6465 c       Original implementation
6466 c       sum_guscdiff=guscdiff(i)
6467 c
6468 c       sum_sguscdiff=0.0d0
6469 c       do k=1,constr_homology
6470 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
6471 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
6472 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
6473 c       enddo
6474 c
6475 c       Implementation of new expressions for gradient (Jan. 2015)
6476 c
6477 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
6478         do k=1,constr_homology
6479 c
6480 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
6481 c       before. Now the drivatives should be correct
6482 c
6483           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6484 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
6485           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6486           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6487 c
6488 c         New implementation
6489 c
6490           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
6491      &                 sigma_d(k,i) ! for the grad wrt r'
6492 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
6493 c
6494 c
6495 c        New implementation
6496          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
6497          do jik=1,3
6498             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
6499      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
6500      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
6501             duscdiff(jik,i)=duscdiff(jik,i)+
6502      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
6503      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
6504             duscdiffx(jik,i)=duscdiffx(jik,i)+
6505      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
6506      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
6507 c
6508 #ifdef DEBUG
6509              write(iout,*) "jik",jik,"i",i
6510              write(iout,*) "dxx, dyy, dzz"
6511              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6512              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
6513 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
6514 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
6515 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
6516 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
6517 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
6518 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
6519 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
6520 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
6521 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
6522 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
6523 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
6524 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
6525 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
6526 c            endif
6527 #endif
6528          enddo
6529         enddo
6530 c
6531 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
6532 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
6533 c
6534 c        write (iout,*) i," uscdiff",uscdiff(i)
6535 c
6536 c Put together deviations from local geometry
6537
6538 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
6539 c      &            wfrag_back(3,i,iset)*uscdiff(i)
6540         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
6541 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
6542 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
6543 c       Uconst_back=Uconst_back+usc_diff(i)
6544 c
6545 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
6546 c
6547 c     New implment: multiplied by sum_sguscdiff
6548 c
6549
6550       enddo ! (i-loop for dscdiff)
6551
6552 c      endif
6553
6554 #ifdef DEBUG
6555       write(iout,*) "------- SC restrs end -------"
6556         write (iout,*) "------ After SC loop in e_modeller ------"
6557         do i=loc_start,loc_end
6558          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
6559          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
6560         enddo
6561       if (waga_theta.eq.1.0d0) then
6562       write (iout,*) "in e_modeller after SC restr end: dutheta"
6563       do i=ithet_start,ithet_end
6564         write (iout,*) i,dutheta(i)
6565       enddo
6566       endif
6567       if (waga_d.eq.1.0d0) then
6568       write (iout,*) "e_modeller after SC loop: duscdiff/x"
6569       do i=1,nres
6570         write (iout,*) i,(duscdiff(j,i),j=1,3)
6571         write (iout,*) i,(duscdiffx(j,i),j=1,3)
6572       enddo
6573       endif
6574 #endif
6575
6576 c Total energy from homology restraints
6577 #ifdef DEBUG
6578       write (iout,*) "odleg",odleg," kat",kat
6579 #endif
6580 c
6581 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
6582 c
6583 c     ehomology_constr=odleg+kat
6584 c
6585 c     For Lorentzian-type Urestr
6586 c
6587
6588       if (waga_dist.ge.0.0d0) then
6589 c
6590 c          For Gaussian-type Urestr
6591 c
6592         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
6593      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6594 c     write (iout,*) "ehomology_constr=",ehomology_constr
6595       else
6596 c
6597 c          For Lorentzian-type Urestr
6598 c
6599         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
6600      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6601 c     write (iout,*) "ehomology_constr=",ehomology_constr
6602       endif
6603 #ifdef DEBUG
6604       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
6605      & "Eval",waga_theta,eval,
6606      &   "Erot",waga_d,Erot
6607       write (iout,*) "ehomology_constr",ehomology_constr
6608 #endif
6609       return
6610 c
6611 c FP 01/15 end
6612 c
6613   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6614   747 format(a12,i4,i4,i4,f8.3,f8.3)
6615   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6616   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6617   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6618      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6619       end
6620
6621 c------------------------------------------------------------------------------
6622       subroutine etor_d(etors_d)
6623 C 6/23/01 Compute double torsional energy
6624       implicit real*8 (a-h,o-z)
6625       include 'DIMENSIONS'
6626       include 'COMMON.VAR'
6627       include 'COMMON.GEO'
6628       include 'COMMON.LOCAL'
6629       include 'COMMON.TORSION'
6630       include 'COMMON.INTERACT'
6631       include 'COMMON.DERIV'
6632       include 'COMMON.CHAIN'
6633       include 'COMMON.NAMES'
6634       include 'COMMON.IOUNITS'
6635       include 'COMMON.FFIELD'
6636       include 'COMMON.TORCNSTR'
6637       include 'COMMON.CONTROL'
6638       logical lprn
6639 C Set lprn=.true. for debugging
6640       lprn=.false.
6641 c     lprn=.true.
6642       etors_d=0.0D0
6643       do i=iphid_start,iphid_end
6644         etors_d_ii=0.0D0
6645         itori=itortyp(itype(i-2))
6646         itori1=itortyp(itype(i-1))
6647         itori2=itortyp(itype(i))
6648         phii=phi(i)
6649         phii1=phi(i+1)
6650         gloci1=0.0D0
6651         gloci2=0.0D0
6652         do j=1,ntermd_1(itori,itori1,itori2)
6653           v1cij=v1c(1,j,itori,itori1,itori2)
6654           v1sij=v1s(1,j,itori,itori1,itori2)
6655           v2cij=v1c(2,j,itori,itori1,itori2)
6656           v2sij=v1s(2,j,itori,itori1,itori2)
6657           cosphi1=dcos(j*phii)
6658           sinphi1=dsin(j*phii)
6659           cosphi2=dcos(j*phii1)
6660           sinphi2=dsin(j*phii1)
6661           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6662      &     v2cij*cosphi2+v2sij*sinphi2
6663           if (energy_dec) etors_d_ii=etors_d_ii+
6664      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6665           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6666           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6667         enddo
6668         do k=2,ntermd_2(itori,itori1,itori2)
6669           do l=1,k-1
6670             v1cdij = v2c(k,l,itori,itori1,itori2)
6671             v2cdij = v2c(l,k,itori,itori1,itori2)
6672             v1sdij = v2s(k,l,itori,itori1,itori2)
6673             v2sdij = v2s(l,k,itori,itori1,itori2)
6674             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6675             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6676             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6677             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6678             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6679      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6680             if (energy_dec) etors_d_ii=etors_d_ii+
6681      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6682      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6683             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6684      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6685             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6686      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6687           enddo
6688         enddo
6689         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6690      &        'etor_d',i,etors_d_ii
6691         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6692         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6693 c        write (iout,*) "gloci", gloc(i-3,icg)
6694       enddo
6695       return
6696       end
6697 #endif
6698 c------------------------------------------------------------------------------
6699       subroutine eback_sc_corr(esccor)
6700 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6701 c        conformational states; temporarily implemented as differences
6702 c        between UNRES torsional potentials (dependent on three types of
6703 c        residues) and the torsional potentials dependent on all 20 types
6704 c        of residues computed from AM1  energy surfaces of terminally-blocked
6705 c        amino-acid residues.
6706       implicit real*8 (a-h,o-z)
6707       include 'DIMENSIONS'
6708       include 'COMMON.VAR'
6709       include 'COMMON.GEO'
6710       include 'COMMON.LOCAL'
6711       include 'COMMON.TORSION'
6712       include 'COMMON.SCCOR'
6713       include 'COMMON.INTERACT'
6714       include 'COMMON.DERIV'
6715       include 'COMMON.CHAIN'
6716       include 'COMMON.NAMES'
6717       include 'COMMON.IOUNITS'
6718       include 'COMMON.FFIELD'
6719       include 'COMMON.CONTROL'
6720       logical lprn
6721 C Set lprn=.true. for debugging
6722       lprn=.false.
6723 c      lprn=.true.
6724 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6725       esccor=0.0D0
6726       do i=itau_start,itau_end
6727         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6728         isccori=isccortyp(itype(i-2))
6729         isccori1=isccortyp(itype(i-1))
6730         phii=phi(i)
6731 cccc  Added 9 May 2012
6732 cc Tauangle is torsional engle depending on the value of first digit
6733 c(see comment below)
6734 cc Omicron is flat angle depending on the value of first digit
6735 c(see comment below)
6736
6737
6738         do intertyp=1,3 !intertyp
6739          esccor_ii=0.0D0
6740 cc Added 09 May 2012 (Adasko)
6741 cc  Intertyp means interaction type of backbone mainchain correlation:
6742 c   1 = SC...Ca...Ca...Ca
6743 c   2 = Ca...Ca...Ca...SC
6744 c   3 = SC...Ca...Ca...SCi
6745         gloci=0.0D0
6746         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6747      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6748      &      (itype(i-1).eq.21)))
6749      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6750      &     .or.(itype(i-2).eq.21)))
6751      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6752      &      (itype(i-1).eq.21)))) cycle
6753         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6754         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6755      & cycle
6756         do j=1,nterm_sccor(isccori,isccori1)
6757           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6758           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6759           cosphi=dcos(j*tauangle(intertyp,i))
6760           sinphi=dsin(j*tauangle(intertyp,i))
6761           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6762           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6763           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6764         enddo
6765          if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
6766      &         'esccor',i,intertyp,esccor_ii
6767         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6768 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6769 c     &gloc_sc(intertyp,i-3,icg)
6770         if (lprn)
6771      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6772      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6773      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6774      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6775         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6776        enddo !intertyp
6777       enddo
6778 c        do i=1,nres
6779 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6780 c        enddo
6781       return
6782       end
6783 c----------------------------------------------------------------------------
6784       subroutine multibody(ecorr)
6785 C This subroutine calculates multi-body contributions to energy following
6786 C the idea of Skolnick et al. If side chains I and J make a contact and
6787 C at the same time side chains I+1 and J+1 make a contact, an extra
6788 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6789       implicit real*8 (a-h,o-z)
6790       include 'DIMENSIONS'
6791       include 'COMMON.IOUNITS'
6792       include 'COMMON.DERIV'
6793       include 'COMMON.INTERACT'
6794       include 'COMMON.CONTACTS'
6795       double precision gx(3),gx1(3)
6796       logical lprn
6797
6798 C Set lprn=.true. for debugging
6799       lprn=.false.
6800
6801       if (lprn) then
6802         write (iout,'(a)') 'Contact function values:'
6803         do i=nnt,nct-2
6804           write (iout,'(i2,20(1x,i2,f10.5))')
6805      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6806         enddo
6807       endif
6808       ecorr=0.0D0
6809       do i=nnt,nct
6810         do j=1,3
6811           gradcorr(j,i)=0.0D0
6812           gradxorr(j,i)=0.0D0
6813         enddo
6814       enddo
6815       do i=nnt,nct-2
6816
6817         DO ISHIFT = 3,4
6818
6819         i1=i+ishift
6820         num_conti=num_cont(i)
6821         num_conti1=num_cont(i1)
6822         do jj=1,num_conti
6823           j=jcont(jj,i)
6824           do kk=1,num_conti1
6825             j1=jcont(kk,i1)
6826             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6827 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6828 cd   &                   ' ishift=',ishift
6829 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6830 C The system gains extra energy.
6831               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6832             endif   ! j1==j+-ishift
6833           enddo     ! kk
6834         enddo       ! jj
6835
6836         ENDDO ! ISHIFT
6837
6838       enddo         ! i
6839       return
6840       end
6841 c------------------------------------------------------------------------------
6842       double precision function esccorr(i,j,k,l,jj,kk)
6843       implicit real*8 (a-h,o-z)
6844       include 'DIMENSIONS'
6845       include 'COMMON.IOUNITS'
6846       include 'COMMON.DERIV'
6847       include 'COMMON.INTERACT'
6848       include 'COMMON.CONTACTS'
6849       double precision gx(3),gx1(3)
6850       logical lprn
6851       lprn=.false.
6852       eij=facont(jj,i)
6853       ekl=facont(kk,k)
6854 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6855 C Calculate the multi-body contribution to energy.
6856 C Calculate multi-body contributions to the gradient.
6857 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6858 cd   & k,l,(gacont(m,kk,k),m=1,3)
6859       do m=1,3
6860         gx(m) =ekl*gacont(m,jj,i)
6861         gx1(m)=eij*gacont(m,kk,k)
6862         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6863         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6864         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6865         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6866       enddo
6867       do m=i,j-1
6868         do ll=1,3
6869           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6870         enddo
6871       enddo
6872       do m=k,l-1
6873         do ll=1,3
6874           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6875         enddo
6876       enddo
6877       esccorr=-eij*ekl
6878       return
6879       end
6880 c------------------------------------------------------------------------------
6881       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6882 C This subroutine calculates multi-body contributions to hydrogen-bonding
6883       implicit real*8 (a-h,o-z)
6884       include 'DIMENSIONS'
6885       include 'COMMON.IOUNITS'
6886 #ifdef MPI
6887       include "mpif.h"
6888       parameter (max_cont=maxconts)
6889       parameter (max_dim=26)
6890       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6891       double precision zapas(max_dim,maxconts,max_fg_procs),
6892      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6893       common /przechowalnia/ zapas
6894       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6895      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6896 #endif
6897       include 'COMMON.SETUP'
6898       include 'COMMON.FFIELD'
6899       include 'COMMON.DERIV'
6900       include 'COMMON.INTERACT'
6901       include 'COMMON.CONTACTS'
6902       include 'COMMON.CONTROL'
6903       include 'COMMON.LOCAL'
6904       double precision gx(3),gx1(3),time00
6905       logical lprn,ldone
6906
6907 C Set lprn=.true. for debugging
6908       lprn=.false.
6909 #ifdef MPI
6910       n_corr=0
6911       n_corr1=0
6912       if (nfgtasks.le.1) goto 30
6913       if (lprn) then
6914         write (iout,'(a)') 'Contact function values before RECEIVE:'
6915         do i=nnt,nct-2
6916           write (iout,'(2i3,50(1x,i2,f5.2))')
6917      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6918      &    j=1,num_cont_hb(i))
6919         enddo
6920       endif
6921       call flush(iout)
6922       do i=1,ntask_cont_from
6923         ncont_recv(i)=0
6924       enddo
6925       do i=1,ntask_cont_to
6926         ncont_sent(i)=0
6927       enddo
6928 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6929 c     & ntask_cont_to
6930 C Make the list of contacts to send to send to other procesors
6931 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6932 c      call flush(iout)
6933       do i=iturn3_start,iturn3_end
6934 c        write (iout,*) "make contact list turn3",i," num_cont",
6935 c     &    num_cont_hb(i)
6936         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6937       enddo
6938       do i=iturn4_start,iturn4_end
6939 c        write (iout,*) "make contact list turn4",i," num_cont",
6940 c     &   num_cont_hb(i)
6941         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6942       enddo
6943       do ii=1,nat_sent
6944         i=iat_sent(ii)
6945 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6946 c     &    num_cont_hb(i)
6947         do j=1,num_cont_hb(i)
6948         do k=1,4
6949           jjc=jcont_hb(j,i)
6950           iproc=iint_sent_local(k,jjc,ii)
6951 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6952           if (iproc.gt.0) then
6953             ncont_sent(iproc)=ncont_sent(iproc)+1
6954             nn=ncont_sent(iproc)
6955             zapas(1,nn,iproc)=i
6956             zapas(2,nn,iproc)=jjc
6957             zapas(3,nn,iproc)=facont_hb(j,i)
6958             zapas(4,nn,iproc)=ees0p(j,i)
6959             zapas(5,nn,iproc)=ees0m(j,i)
6960             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6961             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6962             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6963             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6964             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6965             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6966             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6967             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6968             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6969             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6970             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6971             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6972             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6973             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6974             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6975             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6976             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6977             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6978             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6979             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6980             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6981           endif
6982         enddo
6983         enddo
6984       enddo
6985       if (lprn) then
6986       write (iout,*)
6987      &  "Numbers of contacts to be sent to other processors",
6988      &  (ncont_sent(i),i=1,ntask_cont_to)
6989       write (iout,*) "Contacts sent"
6990       do ii=1,ntask_cont_to
6991         nn=ncont_sent(ii)
6992         iproc=itask_cont_to(ii)
6993         write (iout,*) nn," contacts to processor",iproc,
6994      &   " of CONT_TO_COMM group"
6995         do i=1,nn
6996           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6997         enddo
6998       enddo
6999       call flush(iout)
7000       endif
7001       CorrelType=477
7002       CorrelID=fg_rank+1
7003       CorrelType1=478
7004       CorrelID1=nfgtasks+fg_rank+1
7005       ireq=0
7006 C Receive the numbers of needed contacts from other processors
7007       do ii=1,ntask_cont_from
7008         iproc=itask_cont_from(ii)
7009         ireq=ireq+1
7010         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7011      &    FG_COMM,req(ireq),IERR)
7012       enddo
7013 c      write (iout,*) "IRECV ended"
7014 c      call flush(iout)
7015 C Send the number of contacts needed by other processors
7016       do ii=1,ntask_cont_to
7017         iproc=itask_cont_to(ii)
7018         ireq=ireq+1
7019         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7020      &    FG_COMM,req(ireq),IERR)
7021       enddo
7022 c      write (iout,*) "ISEND ended"
7023 c      write (iout,*) "number of requests (nn)",ireq
7024       call flush(iout)
7025       if (ireq.gt.0)
7026      &  call MPI_Waitall(ireq,req,status_array,ierr)
7027 c      write (iout,*)
7028 c     &  "Numbers of contacts to be received from other processors",
7029 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7030 c      call flush(iout)
7031 C Receive contacts
7032       ireq=0
7033       do ii=1,ntask_cont_from
7034         iproc=itask_cont_from(ii)
7035         nn=ncont_recv(ii)
7036 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7037 c     &   " of CONT_TO_COMM group"
7038         call flush(iout)
7039         if (nn.gt.0) then
7040           ireq=ireq+1
7041           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7042      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7043 c          write (iout,*) "ireq,req",ireq,req(ireq)
7044         endif
7045       enddo
7046 C Send the contacts to processors that need them
7047       do ii=1,ntask_cont_to
7048         iproc=itask_cont_to(ii)
7049         nn=ncont_sent(ii)
7050 c        write (iout,*) nn," contacts to processor",iproc,
7051 c     &   " of CONT_TO_COMM group"
7052         if (nn.gt.0) then
7053           ireq=ireq+1
7054           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7055      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7056 c          write (iout,*) "ireq,req",ireq,req(ireq)
7057 c          do i=1,nn
7058 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7059 c          enddo
7060         endif
7061       enddo
7062 c      write (iout,*) "number of requests (contacts)",ireq
7063 c      write (iout,*) "req",(req(i),i=1,4)
7064 c      call flush(iout)
7065       if (ireq.gt.0)
7066      & call MPI_Waitall(ireq,req,status_array,ierr)
7067       do iii=1,ntask_cont_from
7068         iproc=itask_cont_from(iii)
7069         nn=ncont_recv(iii)
7070         if (lprn) then
7071         write (iout,*) "Received",nn," contacts from processor",iproc,
7072      &   " of CONT_FROM_COMM group"
7073         call flush(iout)
7074         do i=1,nn
7075           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7076         enddo
7077         call flush(iout)
7078         endif
7079         do i=1,nn
7080           ii=zapas_recv(1,i,iii)
7081 c Flag the received contacts to prevent double-counting
7082           jj=-zapas_recv(2,i,iii)
7083 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7084 c          call flush(iout)
7085           nnn=num_cont_hb(ii)+1
7086           num_cont_hb(ii)=nnn
7087           jcont_hb(nnn,ii)=jj
7088           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7089           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7090           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7091           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7092           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7093           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7094           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7095           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7096           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7097           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7098           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7099           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7100           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7101           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7102           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7103           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7104           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7105           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7106           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7107           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7108           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7109           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7110           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7111           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7112         enddo
7113       enddo
7114       call flush(iout)
7115       if (lprn) then
7116         write (iout,'(a)') 'Contact function values after receive:'
7117         do i=nnt,nct-2
7118           write (iout,'(2i3,50(1x,i3,f5.2))')
7119      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7120      &    j=1,num_cont_hb(i))
7121         enddo
7122         call flush(iout)
7123       endif
7124    30 continue
7125 #endif
7126       if (lprn) then
7127         write (iout,'(a)') 'Contact function values:'
7128         do i=nnt,nct-2
7129           write (iout,'(2i3,50(1x,i3,f5.2))')
7130      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7131      &    j=1,num_cont_hb(i))
7132         enddo
7133       endif
7134       ecorr=0.0D0
7135 C Remove the loop below after debugging !!!
7136       do i=nnt,nct
7137         do j=1,3
7138           gradcorr(j,i)=0.0D0
7139           gradxorr(j,i)=0.0D0
7140         enddo
7141       enddo
7142 C Calculate the local-electrostatic correlation terms
7143       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7144         i1=i+1
7145         num_conti=num_cont_hb(i)
7146         num_conti1=num_cont_hb(i+1)
7147         do jj=1,num_conti
7148           j=jcont_hb(jj,i)
7149           jp=iabs(j)
7150           do kk=1,num_conti1
7151             j1=jcont_hb(kk,i1)
7152             jp1=iabs(j1)
7153 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7154 c     &         ' jj=',jj,' kk=',kk
7155             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7156      &          .or. j.lt.0 .and. j1.gt.0) .and.
7157      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7158 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7159 C The system gains extra energy.
7160               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7161               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7162      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7163               n_corr=n_corr+1
7164             else if (j1.eq.j) then
7165 C Contacts I-J and I-(J+1) occur simultaneously.
7166 C The system loses extra energy.
7167 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7168             endif
7169           enddo ! kk
7170           do kk=1,num_conti
7171             j1=jcont_hb(kk,i)
7172 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7173 c    &         ' jj=',jj,' kk=',kk
7174             if (j1.eq.j+1) then
7175 C Contacts I-J and (I+1)-J occur simultaneously.
7176 C The system loses extra energy.
7177 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7178             endif ! j1==j+1
7179           enddo ! kk
7180         enddo ! jj
7181       enddo ! i
7182       return
7183       end
7184 c------------------------------------------------------------------------------
7185       subroutine add_hb_contact(ii,jj,itask)
7186       implicit real*8 (a-h,o-z)
7187       include "DIMENSIONS"
7188       include "COMMON.IOUNITS"
7189       integer max_cont
7190       integer max_dim
7191       parameter (max_cont=maxconts)
7192       parameter (max_dim=26)
7193       include "COMMON.CONTACTS"
7194       double precision zapas(max_dim,maxconts,max_fg_procs),
7195      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7196       common /przechowalnia/ zapas
7197       integer i,j,ii,jj,iproc,itask(4),nn
7198 c      write (iout,*) "itask",itask
7199       do i=1,2
7200         iproc=itask(i)
7201         if (iproc.gt.0) then
7202           do j=1,num_cont_hb(ii)
7203             jjc=jcont_hb(j,ii)
7204 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7205             if (jjc.eq.jj) then
7206               ncont_sent(iproc)=ncont_sent(iproc)+1
7207               nn=ncont_sent(iproc)
7208               zapas(1,nn,iproc)=ii
7209               zapas(2,nn,iproc)=jjc
7210               zapas(3,nn,iproc)=facont_hb(j,ii)
7211               zapas(4,nn,iproc)=ees0p(j,ii)
7212               zapas(5,nn,iproc)=ees0m(j,ii)
7213               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7214               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7215               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7216               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7217               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7218               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7219               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7220               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7221               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7222               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7223               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7224               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7225               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7226               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7227               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7228               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7229               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7230               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7231               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7232               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7233               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7234               exit
7235             endif
7236           enddo
7237         endif
7238       enddo
7239       return
7240       end
7241 c------------------------------------------------------------------------------
7242       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7243      &  n_corr1)
7244 C This subroutine calculates multi-body contributions to hydrogen-bonding
7245       implicit real*8 (a-h,o-z)
7246       include 'DIMENSIONS'
7247       include 'COMMON.IOUNITS'
7248 #ifdef MPI
7249       include "mpif.h"
7250       parameter (max_cont=maxconts)
7251       parameter (max_dim=70)
7252       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7253       double precision zapas(max_dim,maxconts,max_fg_procs),
7254      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7255       common /przechowalnia/ zapas
7256       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7257      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7258 #endif
7259       include 'COMMON.SETUP'
7260       include 'COMMON.FFIELD'
7261       include 'COMMON.DERIV'
7262       include 'COMMON.LOCAL'
7263       include 'COMMON.INTERACT'
7264       include 'COMMON.CONTACTS'
7265       include 'COMMON.CHAIN'
7266       include 'COMMON.CONTROL'
7267       double precision gx(3),gx1(3)
7268       integer num_cont_hb_old(maxres)
7269       logical lprn,ldone
7270       double precision eello4,eello5,eelo6,eello_turn6
7271       external eello4,eello5,eello6,eello_turn6
7272 C Set lprn=.true. for debugging
7273       lprn=.false.
7274       eturn6=0.0d0
7275 #ifdef MPI
7276       do i=1,nres
7277         num_cont_hb_old(i)=num_cont_hb(i)
7278       enddo
7279       n_corr=0
7280       n_corr1=0
7281       if (nfgtasks.le.1) goto 30
7282       if (lprn) then
7283         write (iout,'(a)') 'Contact function values before RECEIVE:'
7284         do i=nnt,nct-2
7285           write (iout,'(2i3,50(1x,i2,f5.2))')
7286      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7287      &    j=1,num_cont_hb(i))
7288         enddo
7289       endif
7290       call flush(iout)
7291       do i=1,ntask_cont_from
7292         ncont_recv(i)=0
7293       enddo
7294       do i=1,ntask_cont_to
7295         ncont_sent(i)=0
7296       enddo
7297 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7298 c     & ntask_cont_to
7299 C Make the list of contacts to send to send to other procesors
7300       do i=iturn3_start,iturn3_end
7301 c        write (iout,*) "make contact list turn3",i," num_cont",
7302 c     &    num_cont_hb(i)
7303         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7304       enddo
7305       do i=iturn4_start,iturn4_end
7306 c        write (iout,*) "make contact list turn4",i," num_cont",
7307 c     &   num_cont_hb(i)
7308         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7309       enddo
7310       do ii=1,nat_sent
7311         i=iat_sent(ii)
7312 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7313 c     &    num_cont_hb(i)
7314         do j=1,num_cont_hb(i)
7315         do k=1,4
7316           jjc=jcont_hb(j,i)
7317           iproc=iint_sent_local(k,jjc,ii)
7318 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7319           if (iproc.ne.0) then
7320             ncont_sent(iproc)=ncont_sent(iproc)+1
7321             nn=ncont_sent(iproc)
7322             zapas(1,nn,iproc)=i
7323             zapas(2,nn,iproc)=jjc
7324             zapas(3,nn,iproc)=d_cont(j,i)
7325             ind=3
7326             do kk=1,3
7327               ind=ind+1
7328               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7329             enddo
7330             do kk=1,2
7331               do ll=1,2
7332                 ind=ind+1
7333                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7334               enddo
7335             enddo
7336             do jj=1,5
7337               do kk=1,3
7338                 do ll=1,2
7339                   do mm=1,2
7340                     ind=ind+1
7341                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7342                   enddo
7343                 enddo
7344               enddo
7345             enddo
7346           endif
7347         enddo
7348         enddo
7349       enddo
7350       if (lprn) then
7351       write (iout,*)
7352      &  "Numbers of contacts to be sent to other processors",
7353      &  (ncont_sent(i),i=1,ntask_cont_to)
7354       write (iout,*) "Contacts sent"
7355       do ii=1,ntask_cont_to
7356         nn=ncont_sent(ii)
7357         iproc=itask_cont_to(ii)
7358         write (iout,*) nn," contacts to processor",iproc,
7359      &   " of CONT_TO_COMM group"
7360         do i=1,nn
7361           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7362         enddo
7363       enddo
7364       call flush(iout)
7365       endif
7366       CorrelType=477
7367       CorrelID=fg_rank+1
7368       CorrelType1=478
7369       CorrelID1=nfgtasks+fg_rank+1
7370       ireq=0
7371 C Receive the numbers of needed contacts from other processors
7372       do ii=1,ntask_cont_from
7373         iproc=itask_cont_from(ii)
7374         ireq=ireq+1
7375         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7376      &    FG_COMM,req(ireq),IERR)
7377       enddo
7378 c      write (iout,*) "IRECV ended"
7379 c      call flush(iout)
7380 C Send the number of contacts needed by other processors
7381       do ii=1,ntask_cont_to
7382         iproc=itask_cont_to(ii)
7383         ireq=ireq+1
7384         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7385      &    FG_COMM,req(ireq),IERR)
7386       enddo
7387 c      write (iout,*) "ISEND ended"
7388 c      write (iout,*) "number of requests (nn)",ireq
7389       call flush(iout)
7390       if (ireq.gt.0)
7391      &  call MPI_Waitall(ireq,req,status_array,ierr)
7392 c      write (iout,*)
7393 c     &  "Numbers of contacts to be received from other processors",
7394 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7395 c      call flush(iout)
7396 C Receive contacts
7397       ireq=0
7398       do ii=1,ntask_cont_from
7399         iproc=itask_cont_from(ii)
7400         nn=ncont_recv(ii)
7401 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7402 c     &   " of CONT_TO_COMM group"
7403         call flush(iout)
7404         if (nn.gt.0) then
7405           ireq=ireq+1
7406           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7407      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7408 c          write (iout,*) "ireq,req",ireq,req(ireq)
7409         endif
7410       enddo
7411 C Send the contacts to processors that need them
7412       do ii=1,ntask_cont_to
7413         iproc=itask_cont_to(ii)
7414         nn=ncont_sent(ii)
7415 c        write (iout,*) nn," contacts to processor",iproc,
7416 c     &   " of CONT_TO_COMM group"
7417         if (nn.gt.0) then
7418           ireq=ireq+1
7419           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7420      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7421 c          write (iout,*) "ireq,req",ireq,req(ireq)
7422 c          do i=1,nn
7423 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7424 c          enddo
7425         endif
7426       enddo
7427 c      write (iout,*) "number of requests (contacts)",ireq
7428 c      write (iout,*) "req",(req(i),i=1,4)
7429 c      call flush(iout)
7430       if (ireq.gt.0)
7431      & call MPI_Waitall(ireq,req,status_array,ierr)
7432       do iii=1,ntask_cont_from
7433         iproc=itask_cont_from(iii)
7434         nn=ncont_recv(iii)
7435         if (lprn) then
7436         write (iout,*) "Received",nn," contacts from processor",iproc,
7437      &   " of CONT_FROM_COMM group"
7438         call flush(iout)
7439         do i=1,nn
7440           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7441         enddo
7442         call flush(iout)
7443         endif
7444         do i=1,nn
7445           ii=zapas_recv(1,i,iii)
7446 c Flag the received contacts to prevent double-counting
7447           jj=-zapas_recv(2,i,iii)
7448 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7449 c          call flush(iout)
7450           nnn=num_cont_hb(ii)+1
7451           num_cont_hb(ii)=nnn
7452           jcont_hb(nnn,ii)=jj
7453           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7454           ind=3
7455           do kk=1,3
7456             ind=ind+1
7457             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7458           enddo
7459           do kk=1,2
7460             do ll=1,2
7461               ind=ind+1
7462               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7463             enddo
7464           enddo
7465           do jj=1,5
7466             do kk=1,3
7467               do ll=1,2
7468                 do mm=1,2
7469                   ind=ind+1
7470                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7471                 enddo
7472               enddo
7473             enddo
7474           enddo
7475         enddo
7476       enddo
7477       call flush(iout)
7478       if (lprn) then
7479         write (iout,'(a)') 'Contact function values after receive:'
7480         do i=nnt,nct-2
7481           write (iout,'(2i3,50(1x,i3,5f6.3))')
7482      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7483      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7484         enddo
7485         call flush(iout)
7486       endif
7487    30 continue
7488 #endif
7489       if (lprn) then
7490         write (iout,'(a)') 'Contact function values:'
7491         do i=nnt,nct-2
7492           write (iout,'(2i3,50(1x,i2,5f6.3))')
7493      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7494      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7495         enddo
7496       endif
7497       ecorr=0.0D0
7498       ecorr5=0.0d0
7499       ecorr6=0.0d0
7500 C Remove the loop below after debugging !!!
7501       do i=nnt,nct
7502         do j=1,3
7503           gradcorr(j,i)=0.0D0
7504           gradxorr(j,i)=0.0D0
7505         enddo
7506       enddo
7507 C Calculate the dipole-dipole interaction energies
7508       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7509       do i=iatel_s,iatel_e+1
7510         num_conti=num_cont_hb(i)
7511         do jj=1,num_conti
7512           j=jcont_hb(jj,i)
7513 #ifdef MOMENT
7514           call dipole(i,j,jj)
7515 #endif
7516         enddo
7517       enddo
7518       endif
7519 C Calculate the local-electrostatic correlation terms
7520 c                write (iout,*) "gradcorr5 in eello5 before loop"
7521 c                do iii=1,nres
7522 c                  write (iout,'(i5,3f10.5)')
7523 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7524 c                enddo
7525       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7526 c        write (iout,*) "corr loop i",i
7527         i1=i+1
7528         num_conti=num_cont_hb(i)
7529         num_conti1=num_cont_hb(i+1)
7530         do jj=1,num_conti
7531           j=jcont_hb(jj,i)
7532           jp=iabs(j)
7533           do kk=1,num_conti1
7534             j1=jcont_hb(kk,i1)
7535             jp1=iabs(j1)
7536 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7537 c     &         ' jj=',jj,' kk=',kk
7538 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7539             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7540      &          .or. j.lt.0 .and. j1.gt.0) .and.
7541      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7542 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7543 C The system gains extra energy.
7544               n_corr=n_corr+1
7545               sqd1=dsqrt(d_cont(jj,i))
7546               sqd2=dsqrt(d_cont(kk,i1))
7547               sred_geom = sqd1*sqd2
7548               IF (sred_geom.lt.cutoff_corr) THEN
7549                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7550      &            ekont,fprimcont)
7551 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7552 cd     &         ' jj=',jj,' kk=',kk
7553                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7554                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7555                 do l=1,3
7556                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7557                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7558                 enddo
7559                 n_corr1=n_corr1+1
7560 cd               write (iout,*) 'sred_geom=',sred_geom,
7561 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7562 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7563 cd               write (iout,*) "g_contij",g_contij
7564 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7565 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7566                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7567                 if (wcorr4.gt.0.0d0)
7568      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7569                   if (energy_dec.and.wcorr4.gt.0.0d0)
7570      1                 write (iout,'(a6,4i5,0pf7.3)')
7571      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7572 c                write (iout,*) "gradcorr5 before eello5"
7573 c                do iii=1,nres
7574 c                  write (iout,'(i5,3f10.5)')
7575 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7576 c                enddo
7577                 if (wcorr5.gt.0.0d0)
7578      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7579 c                write (iout,*) "gradcorr5 after eello5"
7580 c                do iii=1,nres
7581 c                  write (iout,'(i5,3f10.5)')
7582 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7583 c                enddo
7584                   if (energy_dec.and.wcorr5.gt.0.0d0)
7585      1                 write (iout,'(a6,4i5,0pf7.3)')
7586      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7587 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7588 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7589                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7590      &               .or. wturn6.eq.0.0d0))then
7591 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7592                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7593                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7594      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7595 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7596 cd     &            'ecorr6=',ecorr6
7597 cd                write (iout,'(4e15.5)') sred_geom,
7598 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7599 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7600 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7601                 else if (wturn6.gt.0.0d0
7602      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7603 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7604                   eturn6=eturn6+eello_turn6(i,jj,kk)
7605                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7606      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7607 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7608                 endif
7609               ENDIF
7610 1111          continue
7611             endif
7612           enddo ! kk
7613         enddo ! jj
7614       enddo ! i
7615       do i=1,nres
7616         num_cont_hb(i)=num_cont_hb_old(i)
7617       enddo
7618 c                write (iout,*) "gradcorr5 in eello5"
7619 c                do iii=1,nres
7620 c                  write (iout,'(i5,3f10.5)')
7621 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7622 c                enddo
7623       return
7624       end
7625 c------------------------------------------------------------------------------
7626       subroutine add_hb_contact_eello(ii,jj,itask)
7627       implicit real*8 (a-h,o-z)
7628       include "DIMENSIONS"
7629       include "COMMON.IOUNITS"
7630       integer max_cont
7631       integer max_dim
7632       parameter (max_cont=maxconts)
7633       parameter (max_dim=70)
7634       include "COMMON.CONTACTS"
7635       double precision zapas(max_dim,maxconts,max_fg_procs),
7636      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7637       common /przechowalnia/ zapas
7638       integer i,j,ii,jj,iproc,itask(4),nn
7639 c      write (iout,*) "itask",itask
7640       do i=1,2
7641         iproc=itask(i)
7642         if (iproc.gt.0) then
7643           do j=1,num_cont_hb(ii)
7644             jjc=jcont_hb(j,ii)
7645 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7646             if (jjc.eq.jj) then
7647               ncont_sent(iproc)=ncont_sent(iproc)+1
7648               nn=ncont_sent(iproc)
7649               zapas(1,nn,iproc)=ii
7650               zapas(2,nn,iproc)=jjc
7651               zapas(3,nn,iproc)=d_cont(j,ii)
7652               ind=3
7653               do kk=1,3
7654                 ind=ind+1
7655                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7656               enddo
7657               do kk=1,2
7658                 do ll=1,2
7659                   ind=ind+1
7660                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7661                 enddo
7662               enddo
7663               do jj=1,5
7664                 do kk=1,3
7665                   do ll=1,2
7666                     do mm=1,2
7667                       ind=ind+1
7668                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7669                     enddo
7670                   enddo
7671                 enddo
7672               enddo
7673               exit
7674             endif
7675           enddo
7676         endif
7677       enddo
7678       return
7679       end
7680 c------------------------------------------------------------------------------
7681       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7682       implicit real*8 (a-h,o-z)
7683       include 'DIMENSIONS'
7684       include 'COMMON.IOUNITS'
7685       include 'COMMON.DERIV'
7686       include 'COMMON.INTERACT'
7687       include 'COMMON.CONTACTS'
7688       double precision gx(3),gx1(3)
7689       logical lprn
7690       lprn=.false.
7691       eij=facont_hb(jj,i)
7692       ekl=facont_hb(kk,k)
7693       ees0pij=ees0p(jj,i)
7694       ees0pkl=ees0p(kk,k)
7695       ees0mij=ees0m(jj,i)
7696       ees0mkl=ees0m(kk,k)
7697       ekont=eij*ekl
7698       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7699 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7700 C Following 4 lines for diagnostics.
7701 cd    ees0pkl=0.0D0
7702 cd    ees0pij=1.0D0
7703 cd    ees0mkl=0.0D0
7704 cd    ees0mij=1.0D0
7705 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7706 c     & 'Contacts ',i,j,
7707 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7708 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7709 c     & 'gradcorr_long'
7710 C Calculate the multi-body contribution to energy.
7711 c      ecorr=ecorr+ekont*ees
7712 C Calculate multi-body contributions to the gradient.
7713       coeffpees0pij=coeffp*ees0pij
7714       coeffmees0mij=coeffm*ees0mij
7715       coeffpees0pkl=coeffp*ees0pkl
7716       coeffmees0mkl=coeffm*ees0mkl
7717       do ll=1,3
7718 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7719         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7720      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7721      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7722         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7723      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7724      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7725 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7726         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7727      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7728      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7729         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7730      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7731      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7732         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7733      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7734      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7735         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7736         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7737         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7738      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7739      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7740         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7741         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7742 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7743       enddo
7744 c      write (iout,*)
7745 cgrad      do m=i+1,j-1
7746 cgrad        do ll=1,3
7747 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7748 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7749 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7750 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7751 cgrad        enddo
7752 cgrad      enddo
7753 cgrad      do m=k+1,l-1
7754 cgrad        do ll=1,3
7755 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7756 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7757 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7758 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7759 cgrad        enddo
7760 cgrad      enddo
7761 c      write (iout,*) "ehbcorr",ekont*ees
7762       ehbcorr=ekont*ees
7763       return
7764       end
7765 #ifdef MOMENT
7766 C---------------------------------------------------------------------------
7767       subroutine dipole(i,j,jj)
7768       implicit real*8 (a-h,o-z)
7769       include 'DIMENSIONS'
7770       include 'COMMON.IOUNITS'
7771       include 'COMMON.CHAIN'
7772       include 'COMMON.FFIELD'
7773       include 'COMMON.DERIV'
7774       include 'COMMON.INTERACT'
7775       include 'COMMON.CONTACTS'
7776       include 'COMMON.TORSION'
7777       include 'COMMON.VAR'
7778       include 'COMMON.GEO'
7779       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7780      &  auxmat(2,2)
7781       iti1 = itortyp(itype(i+1))
7782       if (j.lt.nres-1) then
7783         itj1 = itortyp(itype(j+1))
7784       else
7785         itj1=ntortyp+1
7786       endif
7787       do iii=1,2
7788         dipi(iii,1)=Ub2(iii,i)
7789         dipderi(iii)=Ub2der(iii,i)
7790         dipi(iii,2)=b1(iii,iti1)
7791         dipj(iii,1)=Ub2(iii,j)
7792         dipderj(iii)=Ub2der(iii,j)
7793         dipj(iii,2)=b1(iii,itj1)
7794       enddo
7795       kkk=0
7796       do iii=1,2
7797         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7798         do jjj=1,2
7799           kkk=kkk+1
7800           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7801         enddo
7802       enddo
7803       do kkk=1,5
7804         do lll=1,3
7805           mmm=0
7806           do iii=1,2
7807             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7808      &        auxvec(1))
7809             do jjj=1,2
7810               mmm=mmm+1
7811               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7812             enddo
7813           enddo
7814         enddo
7815       enddo
7816       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7817       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7818       do iii=1,2
7819         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7820       enddo
7821       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7822       do iii=1,2
7823         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7824       enddo
7825       return
7826       end
7827 #endif
7828 C---------------------------------------------------------------------------
7829       subroutine calc_eello(i,j,k,l,jj,kk)
7830 C
7831 C This subroutine computes matrices and vectors needed to calculate
7832 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7833 C
7834       implicit real*8 (a-h,o-z)
7835       include 'DIMENSIONS'
7836       include 'COMMON.IOUNITS'
7837       include 'COMMON.CHAIN'
7838       include 'COMMON.DERIV'
7839       include 'COMMON.INTERACT'
7840       include 'COMMON.CONTACTS'
7841       include 'COMMON.TORSION'
7842       include 'COMMON.VAR'
7843       include 'COMMON.GEO'
7844       include 'COMMON.FFIELD'
7845       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7846      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7847       logical lprn
7848       common /kutas/ lprn
7849 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7850 cd     & ' jj=',jj,' kk=',kk
7851 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7852 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7853 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7854       do iii=1,2
7855         do jjj=1,2
7856           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7857           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7858         enddo
7859       enddo
7860       call transpose2(aa1(1,1),aa1t(1,1))
7861       call transpose2(aa2(1,1),aa2t(1,1))
7862       do kkk=1,5
7863         do lll=1,3
7864           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7865      &      aa1tder(1,1,lll,kkk))
7866           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7867      &      aa2tder(1,1,lll,kkk))
7868         enddo
7869       enddo
7870       if (l.eq.j+1) then
7871 C parallel orientation of the two CA-CA-CA frames.
7872         if (i.gt.1) then
7873           iti=itortyp(itype(i))
7874         else
7875           iti=ntortyp+1
7876         endif
7877         itk1=itortyp(itype(k+1))
7878         itj=itortyp(itype(j))
7879         if (l.lt.nres-1) then
7880           itl1=itortyp(itype(l+1))
7881         else
7882           itl1=ntortyp+1
7883         endif
7884 C A1 kernel(j+1) A2T
7885 cd        do iii=1,2
7886 cd          write (iout,'(3f10.5,5x,3f10.5)')
7887 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7888 cd        enddo
7889         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7890      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7891      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7892 C Following matrices are needed only for 6-th order cumulants
7893         IF (wcorr6.gt.0.0d0) THEN
7894         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7895      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7896      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7897         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7898      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7899      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7900      &   ADtEAderx(1,1,1,1,1,1))
7901         lprn=.false.
7902         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7903      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7904      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7905      &   ADtEA1derx(1,1,1,1,1,1))
7906         ENDIF
7907 C End 6-th order cumulants
7908 cd        lprn=.false.
7909 cd        if (lprn) then
7910 cd        write (2,*) 'In calc_eello6'
7911 cd        do iii=1,2
7912 cd          write (2,*) 'iii=',iii
7913 cd          do kkk=1,5
7914 cd            write (2,*) 'kkk=',kkk
7915 cd            do jjj=1,2
7916 cd              write (2,'(3(2f10.5),5x)')
7917 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7918 cd            enddo
7919 cd          enddo
7920 cd        enddo
7921 cd        endif
7922         call transpose2(EUgder(1,1,k),auxmat(1,1))
7923         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7924         call transpose2(EUg(1,1,k),auxmat(1,1))
7925         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7926         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7927         do iii=1,2
7928           do kkk=1,5
7929             do lll=1,3
7930               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7931      &          EAEAderx(1,1,lll,kkk,iii,1))
7932             enddo
7933           enddo
7934         enddo
7935 C A1T kernel(i+1) A2
7936         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7937      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7938      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7939 C Following matrices are needed only for 6-th order cumulants
7940         IF (wcorr6.gt.0.0d0) THEN
7941         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7942      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7943      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7944         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7945      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7946      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7947      &   ADtEAderx(1,1,1,1,1,2))
7948         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7949      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7950      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7951      &   ADtEA1derx(1,1,1,1,1,2))
7952         ENDIF
7953 C End 6-th order cumulants
7954         call transpose2(EUgder(1,1,l),auxmat(1,1))
7955         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7956         call transpose2(EUg(1,1,l),auxmat(1,1))
7957         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7958         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7959         do iii=1,2
7960           do kkk=1,5
7961             do lll=1,3
7962               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7963      &          EAEAderx(1,1,lll,kkk,iii,2))
7964             enddo
7965           enddo
7966         enddo
7967 C AEAb1 and AEAb2
7968 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7969 C They are needed only when the fifth- or the sixth-order cumulants are
7970 C indluded.
7971         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7972         call transpose2(AEA(1,1,1),auxmat(1,1))
7973         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7974         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7975         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7976         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7977         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7978         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7979         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7980         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7981         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7982         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7983         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7984         call transpose2(AEA(1,1,2),auxmat(1,1))
7985         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7986         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7987         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7988         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7989         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7990         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7991         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7992         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7993         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7994         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7995         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7996 C Calculate the Cartesian derivatives of the vectors.
7997         do iii=1,2
7998           do kkk=1,5
7999             do lll=1,3
8000               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8001               call matvec2(auxmat(1,1),b1(1,iti),
8002      &          AEAb1derx(1,lll,kkk,iii,1,1))
8003               call matvec2(auxmat(1,1),Ub2(1,i),
8004      &          AEAb2derx(1,lll,kkk,iii,1,1))
8005               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8006      &          AEAb1derx(1,lll,kkk,iii,2,1))
8007               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8008      &          AEAb2derx(1,lll,kkk,iii,2,1))
8009               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8010               call matvec2(auxmat(1,1),b1(1,itj),
8011      &          AEAb1derx(1,lll,kkk,iii,1,2))
8012               call matvec2(auxmat(1,1),Ub2(1,j),
8013      &          AEAb2derx(1,lll,kkk,iii,1,2))
8014               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8015      &          AEAb1derx(1,lll,kkk,iii,2,2))
8016               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8017      &          AEAb2derx(1,lll,kkk,iii,2,2))
8018             enddo
8019           enddo
8020         enddo
8021         ENDIF
8022 C End vectors
8023       else
8024 C Antiparallel orientation of the two CA-CA-CA frames.
8025         if (i.gt.1) then
8026           iti=itortyp(itype(i))
8027         else
8028           iti=ntortyp+1
8029         endif
8030         itk1=itortyp(itype(k+1))
8031         itl=itortyp(itype(l))
8032         itj=itortyp(itype(j))
8033         if (j.lt.nres-1) then
8034           itj1=itortyp(itype(j+1))
8035         else
8036           itj1=ntortyp+1
8037         endif
8038 C A2 kernel(j-1)T A1T
8039         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8040      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8041      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8042 C Following matrices are needed only for 6-th order cumulants
8043         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8044      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8045         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8046      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8047      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8048         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8049      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8050      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8051      &   ADtEAderx(1,1,1,1,1,1))
8052         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8053      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8054      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8055      &   ADtEA1derx(1,1,1,1,1,1))
8056         ENDIF
8057 C End 6-th order cumulants
8058         call transpose2(EUgder(1,1,k),auxmat(1,1))
8059         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8060         call transpose2(EUg(1,1,k),auxmat(1,1))
8061         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8062         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8063         do iii=1,2
8064           do kkk=1,5
8065             do lll=1,3
8066               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8067      &          EAEAderx(1,1,lll,kkk,iii,1))
8068             enddo
8069           enddo
8070         enddo
8071 C A2T kernel(i+1)T A1
8072         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8073      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8074      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8075 C Following matrices are needed only for 6-th order cumulants
8076         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8077      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8078         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8079      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8080      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8081         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8082      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8083      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8084      &   ADtEAderx(1,1,1,1,1,2))
8085         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8086      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8087      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8088      &   ADtEA1derx(1,1,1,1,1,2))
8089         ENDIF
8090 C End 6-th order cumulants
8091         call transpose2(EUgder(1,1,j),auxmat(1,1))
8092         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8093         call transpose2(EUg(1,1,j),auxmat(1,1))
8094         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8095         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8096         do iii=1,2
8097           do kkk=1,5
8098             do lll=1,3
8099               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8100      &          EAEAderx(1,1,lll,kkk,iii,2))
8101             enddo
8102           enddo
8103         enddo
8104 C AEAb1 and AEAb2
8105 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8106 C They are needed only when the fifth- or the sixth-order cumulants are
8107 C indluded.
8108         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8109      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8110         call transpose2(AEA(1,1,1),auxmat(1,1))
8111         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8112         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8113         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8114         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8115         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8116         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8117         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8118         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8119         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8120         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8121         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8122         call transpose2(AEA(1,1,2),auxmat(1,1))
8123         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8124         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8125         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8126         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8127         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8128         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8129         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8130         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8131         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8132         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8133         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8134 C Calculate the Cartesian derivatives of the vectors.
8135         do iii=1,2
8136           do kkk=1,5
8137             do lll=1,3
8138               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8139               call matvec2(auxmat(1,1),b1(1,iti),
8140      &          AEAb1derx(1,lll,kkk,iii,1,1))
8141               call matvec2(auxmat(1,1),Ub2(1,i),
8142      &          AEAb2derx(1,lll,kkk,iii,1,1))
8143               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8144      &          AEAb1derx(1,lll,kkk,iii,2,1))
8145               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8146      &          AEAb2derx(1,lll,kkk,iii,2,1))
8147               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8148               call matvec2(auxmat(1,1),b1(1,itl),
8149      &          AEAb1derx(1,lll,kkk,iii,1,2))
8150               call matvec2(auxmat(1,1),Ub2(1,l),
8151      &          AEAb2derx(1,lll,kkk,iii,1,2))
8152               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
8153      &          AEAb1derx(1,lll,kkk,iii,2,2))
8154               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8155      &          AEAb2derx(1,lll,kkk,iii,2,2))
8156             enddo
8157           enddo
8158         enddo
8159         ENDIF
8160 C End vectors
8161       endif
8162       return
8163       end
8164 C---------------------------------------------------------------------------
8165       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8166      &  KK,KKderg,AKA,AKAderg,AKAderx)
8167       implicit none
8168       integer nderg
8169       logical transp
8170       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8171      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8172      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8173       integer iii,kkk,lll
8174       integer jjj,mmm
8175       logical lprn
8176       common /kutas/ lprn
8177       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8178       do iii=1,nderg
8179         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8180      &    AKAderg(1,1,iii))
8181       enddo
8182 cd      if (lprn) write (2,*) 'In kernel'
8183       do kkk=1,5
8184 cd        if (lprn) write (2,*) 'kkk=',kkk
8185         do lll=1,3
8186           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8187      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8188 cd          if (lprn) then
8189 cd            write (2,*) 'lll=',lll
8190 cd            write (2,*) 'iii=1'
8191 cd            do jjj=1,2
8192 cd              write (2,'(3(2f10.5),5x)')
8193 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8194 cd            enddo
8195 cd          endif
8196           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8197      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8198 cd          if (lprn) then
8199 cd            write (2,*) 'lll=',lll
8200 cd            write (2,*) 'iii=2'
8201 cd            do jjj=1,2
8202 cd              write (2,'(3(2f10.5),5x)')
8203 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8204 cd            enddo
8205 cd          endif
8206         enddo
8207       enddo
8208       return
8209       end
8210 C---------------------------------------------------------------------------
8211       double precision function eello4(i,j,k,l,jj,kk)
8212       implicit real*8 (a-h,o-z)
8213       include 'DIMENSIONS'
8214       include 'COMMON.IOUNITS'
8215       include 'COMMON.CHAIN'
8216       include 'COMMON.DERIV'
8217       include 'COMMON.INTERACT'
8218       include 'COMMON.CONTACTS'
8219       include 'COMMON.TORSION'
8220       include 'COMMON.VAR'
8221       include 'COMMON.GEO'
8222       double precision pizda(2,2),ggg1(3),ggg2(3)
8223 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8224 cd        eello4=0.0d0
8225 cd        return
8226 cd      endif
8227 cd      print *,'eello4:',i,j,k,l,jj,kk
8228 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8229 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8230 cold      eij=facont_hb(jj,i)
8231 cold      ekl=facont_hb(kk,k)
8232 cold      ekont=eij*ekl
8233       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8234 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8235       gcorr_loc(k-1)=gcorr_loc(k-1)
8236      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8237       if (l.eq.j+1) then
8238         gcorr_loc(l-1)=gcorr_loc(l-1)
8239      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8240       else
8241         gcorr_loc(j-1)=gcorr_loc(j-1)
8242      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8243       endif
8244       do iii=1,2
8245         do kkk=1,5
8246           do lll=1,3
8247             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8248      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8249 cd            derx(lll,kkk,iii)=0.0d0
8250           enddo
8251         enddo
8252       enddo
8253 cd      gcorr_loc(l-1)=0.0d0
8254 cd      gcorr_loc(j-1)=0.0d0
8255 cd      gcorr_loc(k-1)=0.0d0
8256 cd      eel4=1.0d0
8257 cd      write (iout,*)'Contacts have occurred for peptide groups',
8258 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8259 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8260       if (j.lt.nres-1) then
8261         j1=j+1
8262         j2=j-1
8263       else
8264         j1=j-1
8265         j2=j-2
8266       endif
8267       if (l.lt.nres-1) then
8268         l1=l+1
8269         l2=l-1
8270       else
8271         l1=l-1
8272         l2=l-2
8273       endif
8274       do ll=1,3
8275 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8276 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8277         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8278         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8279 cgrad        ghalf=0.5d0*ggg1(ll)
8280         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8281         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8282         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8283         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8284         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8285         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8286 cgrad        ghalf=0.5d0*ggg2(ll)
8287         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8288         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8289         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8290         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8291         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8292         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8293       enddo
8294 cgrad      do m=i+1,j-1
8295 cgrad        do ll=1,3
8296 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8297 cgrad        enddo
8298 cgrad      enddo
8299 cgrad      do m=k+1,l-1
8300 cgrad        do ll=1,3
8301 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8302 cgrad        enddo
8303 cgrad      enddo
8304 cgrad      do m=i+2,j2
8305 cgrad        do ll=1,3
8306 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8307 cgrad        enddo
8308 cgrad      enddo
8309 cgrad      do m=k+2,l2
8310 cgrad        do ll=1,3
8311 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8312 cgrad        enddo
8313 cgrad      enddo
8314 cd      do iii=1,nres-3
8315 cd        write (2,*) iii,gcorr_loc(iii)
8316 cd      enddo
8317       eello4=ekont*eel4
8318 cd      write (2,*) 'ekont',ekont
8319 cd      write (iout,*) 'eello4',ekont*eel4
8320       return
8321       end
8322 C---------------------------------------------------------------------------
8323       double precision function eello5(i,j,k,l,jj,kk)
8324       implicit real*8 (a-h,o-z)
8325       include 'DIMENSIONS'
8326       include 'COMMON.IOUNITS'
8327       include 'COMMON.CHAIN'
8328       include 'COMMON.DERIV'
8329       include 'COMMON.INTERACT'
8330       include 'COMMON.CONTACTS'
8331       include 'COMMON.TORSION'
8332       include 'COMMON.VAR'
8333       include 'COMMON.GEO'
8334       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8335       double precision ggg1(3),ggg2(3)
8336 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8337 C                                                                              C
8338 C                            Parallel chains                                   C
8339 C                                                                              C
8340 C          o             o                   o             o                   C
8341 C         /l\           / \             \   / \           / \   /              C
8342 C        /   \         /   \             \ /   \         /   \ /               C
8343 C       j| o |l1       | o |              o| o |         | o |o                C
8344 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8345 C      \i/   \         /   \ /             /   \         /   \                 C
8346 C       o    k1             o                                                  C
8347 C         (I)          (II)                (III)          (IV)                 C
8348 C                                                                              C
8349 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8350 C                                                                              C
8351 C                            Antiparallel chains                               C
8352 C                                                                              C
8353 C          o             o                   o             o                   C
8354 C         /j\           / \             \   / \           / \   /              C
8355 C        /   \         /   \             \ /   \         /   \ /               C
8356 C      j1| o |l        | o |              o| o |         | o |o                C
8357 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8358 C      \i/   \         /   \ /             /   \         /   \                 C
8359 C       o     k1            o                                                  C
8360 C         (I)          (II)                (III)          (IV)                 C
8361 C                                                                              C
8362 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8363 C                                                                              C
8364 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8365 C                                                                              C
8366 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8367 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8368 cd        eello5=0.0d0
8369 cd        return
8370 cd      endif
8371 cd      write (iout,*)
8372 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8373 cd     &   ' and',k,l
8374       itk=itortyp(itype(k))
8375       itl=itortyp(itype(l))
8376       itj=itortyp(itype(j))
8377       eello5_1=0.0d0
8378       eello5_2=0.0d0
8379       eello5_3=0.0d0
8380       eello5_4=0.0d0
8381 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8382 cd     &   eel5_3_num,eel5_4_num)
8383       do iii=1,2
8384         do kkk=1,5
8385           do lll=1,3
8386             derx(lll,kkk,iii)=0.0d0
8387           enddo
8388         enddo
8389       enddo
8390 cd      eij=facont_hb(jj,i)
8391 cd      ekl=facont_hb(kk,k)
8392 cd      ekont=eij*ekl
8393 cd      write (iout,*)'Contacts have occurred for peptide groups',
8394 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8395 cd      goto 1111
8396 C Contribution from the graph I.
8397 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8398 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8399       call transpose2(EUg(1,1,k),auxmat(1,1))
8400       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8401       vv(1)=pizda(1,1)-pizda(2,2)
8402       vv(2)=pizda(1,2)+pizda(2,1)
8403       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8404      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8405 C Explicit gradient in virtual-dihedral angles.
8406       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8407      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8408      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8409       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8410       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8411       vv(1)=pizda(1,1)-pizda(2,2)
8412       vv(2)=pizda(1,2)+pizda(2,1)
8413       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8414      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8415      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8416       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8417       vv(1)=pizda(1,1)-pizda(2,2)
8418       vv(2)=pizda(1,2)+pizda(2,1)
8419       if (l.eq.j+1) then
8420         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8421      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8422      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8423       else
8424         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8425      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8426      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8427       endif
8428 C Cartesian gradient
8429       do iii=1,2
8430         do kkk=1,5
8431           do lll=1,3
8432             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8433      &        pizda(1,1))
8434             vv(1)=pizda(1,1)-pizda(2,2)
8435             vv(2)=pizda(1,2)+pizda(2,1)
8436             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8437      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8438      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8439           enddo
8440         enddo
8441       enddo
8442 c      goto 1112
8443 c1111  continue
8444 C Contribution from graph II
8445       call transpose2(EE(1,1,itk),auxmat(1,1))
8446       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8447       vv(1)=pizda(1,1)+pizda(2,2)
8448       vv(2)=pizda(2,1)-pizda(1,2)
8449       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8450      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8451 C Explicit gradient in virtual-dihedral angles.
8452       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8453      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8454       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8455       vv(1)=pizda(1,1)+pizda(2,2)
8456       vv(2)=pizda(2,1)-pizda(1,2)
8457       if (l.eq.j+1) then
8458         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8459      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8460      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8461       else
8462         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8463      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8464      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8465       endif
8466 C Cartesian gradient
8467       do iii=1,2
8468         do kkk=1,5
8469           do lll=1,3
8470             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8471      &        pizda(1,1))
8472             vv(1)=pizda(1,1)+pizda(2,2)
8473             vv(2)=pizda(2,1)-pizda(1,2)
8474             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8475      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8476      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8477           enddo
8478         enddo
8479       enddo
8480 cd      goto 1112
8481 cd1111  continue
8482       if (l.eq.j+1) then
8483 cd        goto 1110
8484 C Parallel orientation
8485 C Contribution from graph III
8486         call transpose2(EUg(1,1,l),auxmat(1,1))
8487         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8488         vv(1)=pizda(1,1)-pizda(2,2)
8489         vv(2)=pizda(1,2)+pizda(2,1)
8490         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8491      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8492 C Explicit gradient in virtual-dihedral angles.
8493         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8494      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8495      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8496         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8497         vv(1)=pizda(1,1)-pizda(2,2)
8498         vv(2)=pizda(1,2)+pizda(2,1)
8499         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8500      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8501      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8502         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8503         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8504         vv(1)=pizda(1,1)-pizda(2,2)
8505         vv(2)=pizda(1,2)+pizda(2,1)
8506         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8507      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8508      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8509 C Cartesian gradient
8510         do iii=1,2
8511           do kkk=1,5
8512             do lll=1,3
8513               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8514      &          pizda(1,1))
8515               vv(1)=pizda(1,1)-pizda(2,2)
8516               vv(2)=pizda(1,2)+pizda(2,1)
8517               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8518      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8519      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8520             enddo
8521           enddo
8522         enddo
8523 cd        goto 1112
8524 C Contribution from graph IV
8525 cd1110    continue
8526         call transpose2(EE(1,1,itl),auxmat(1,1))
8527         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8528         vv(1)=pizda(1,1)+pizda(2,2)
8529         vv(2)=pizda(2,1)-pizda(1,2)
8530         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8531      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8532 C Explicit gradient in virtual-dihedral angles.
8533         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8534      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8535         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8536         vv(1)=pizda(1,1)+pizda(2,2)
8537         vv(2)=pizda(2,1)-pizda(1,2)
8538         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8539      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8540      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8541 C Cartesian gradient
8542         do iii=1,2
8543           do kkk=1,5
8544             do lll=1,3
8545               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8546      &          pizda(1,1))
8547               vv(1)=pizda(1,1)+pizda(2,2)
8548               vv(2)=pizda(2,1)-pizda(1,2)
8549               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8550      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8551      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8552             enddo
8553           enddo
8554         enddo
8555       else
8556 C Antiparallel orientation
8557 C Contribution from graph III
8558 c        goto 1110
8559         call transpose2(EUg(1,1,j),auxmat(1,1))
8560         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8561         vv(1)=pizda(1,1)-pizda(2,2)
8562         vv(2)=pizda(1,2)+pizda(2,1)
8563         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8564      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8565 C Explicit gradient in virtual-dihedral angles.
8566         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8567      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8568      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8569         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8570         vv(1)=pizda(1,1)-pizda(2,2)
8571         vv(2)=pizda(1,2)+pizda(2,1)
8572         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8573      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8574      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8575         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8576         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8577         vv(1)=pizda(1,1)-pizda(2,2)
8578         vv(2)=pizda(1,2)+pizda(2,1)
8579         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8580      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8581      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8582 C Cartesian gradient
8583         do iii=1,2
8584           do kkk=1,5
8585             do lll=1,3
8586               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8587      &          pizda(1,1))
8588               vv(1)=pizda(1,1)-pizda(2,2)
8589               vv(2)=pizda(1,2)+pizda(2,1)
8590               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8591      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8592      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8593             enddo
8594           enddo
8595         enddo
8596 cd        goto 1112
8597 C Contribution from graph IV
8598 1110    continue
8599         call transpose2(EE(1,1,itj),auxmat(1,1))
8600         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8601         vv(1)=pizda(1,1)+pizda(2,2)
8602         vv(2)=pizda(2,1)-pizda(1,2)
8603         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8604      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8605 C Explicit gradient in virtual-dihedral angles.
8606         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8607      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8608         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8609         vv(1)=pizda(1,1)+pizda(2,2)
8610         vv(2)=pizda(2,1)-pizda(1,2)
8611         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8612      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8613      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8614 C Cartesian gradient
8615         do iii=1,2
8616           do kkk=1,5
8617             do lll=1,3
8618               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8619      &          pizda(1,1))
8620               vv(1)=pizda(1,1)+pizda(2,2)
8621               vv(2)=pizda(2,1)-pizda(1,2)
8622               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8623      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8624      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8625             enddo
8626           enddo
8627         enddo
8628       endif
8629 1112  continue
8630       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8631 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8632 cd        write (2,*) 'ijkl',i,j,k,l
8633 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8634 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8635 cd      endif
8636 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8637 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8638 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8639 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8640       if (j.lt.nres-1) then
8641         j1=j+1
8642         j2=j-1
8643       else
8644         j1=j-1
8645         j2=j-2
8646       endif
8647       if (l.lt.nres-1) then
8648         l1=l+1
8649         l2=l-1
8650       else
8651         l1=l-1
8652         l2=l-2
8653       endif
8654 cd      eij=1.0d0
8655 cd      ekl=1.0d0
8656 cd      ekont=1.0d0
8657 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8658 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8659 C        summed up outside the subrouine as for the other subroutines
8660 C        handling long-range interactions. The old code is commented out
8661 C        with "cgrad" to keep track of changes.
8662       do ll=1,3
8663 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8664 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8665         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8666         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8667 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8668 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8669 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8670 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8671 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8672 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8673 c     &   gradcorr5ij,
8674 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8675 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8676 cgrad        ghalf=0.5d0*ggg1(ll)
8677 cd        ghalf=0.0d0
8678         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8679         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8680         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8681         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8682         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8683         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8684 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8685 cgrad        ghalf=0.5d0*ggg2(ll)
8686 cd        ghalf=0.0d0
8687         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8688         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8689         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8690         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8691         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8692         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8693       enddo
8694 cd      goto 1112
8695 cgrad      do m=i+1,j-1
8696 cgrad        do ll=1,3
8697 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8698 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8699 cgrad        enddo
8700 cgrad      enddo
8701 cgrad      do m=k+1,l-1
8702 cgrad        do ll=1,3
8703 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8704 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8705 cgrad        enddo
8706 cgrad      enddo
8707 c1112  continue
8708 cgrad      do m=i+2,j2
8709 cgrad        do ll=1,3
8710 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8711 cgrad        enddo
8712 cgrad      enddo
8713 cgrad      do m=k+2,l2
8714 cgrad        do ll=1,3
8715 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8716 cgrad        enddo
8717 cgrad      enddo
8718 cd      do iii=1,nres-3
8719 cd        write (2,*) iii,g_corr5_loc(iii)
8720 cd      enddo
8721       eello5=ekont*eel5
8722 cd      write (2,*) 'ekont',ekont
8723 cd      write (iout,*) 'eello5',ekont*eel5
8724       return
8725       end
8726 c--------------------------------------------------------------------------
8727       double precision function eello6(i,j,k,l,jj,kk)
8728       implicit real*8 (a-h,o-z)
8729       include 'DIMENSIONS'
8730       include 'COMMON.IOUNITS'
8731       include 'COMMON.CHAIN'
8732       include 'COMMON.DERIV'
8733       include 'COMMON.INTERACT'
8734       include 'COMMON.CONTACTS'
8735       include 'COMMON.TORSION'
8736       include 'COMMON.VAR'
8737       include 'COMMON.GEO'
8738       include 'COMMON.FFIELD'
8739       double precision ggg1(3),ggg2(3)
8740 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8741 cd        eello6=0.0d0
8742 cd        return
8743 cd      endif
8744 cd      write (iout,*)
8745 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8746 cd     &   ' and',k,l
8747       eello6_1=0.0d0
8748       eello6_2=0.0d0
8749       eello6_3=0.0d0
8750       eello6_4=0.0d0
8751       eello6_5=0.0d0
8752       eello6_6=0.0d0
8753 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8754 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8755       do iii=1,2
8756         do kkk=1,5
8757           do lll=1,3
8758             derx(lll,kkk,iii)=0.0d0
8759           enddo
8760         enddo
8761       enddo
8762 cd      eij=facont_hb(jj,i)
8763 cd      ekl=facont_hb(kk,k)
8764 cd      ekont=eij*ekl
8765 cd      eij=1.0d0
8766 cd      ekl=1.0d0
8767 cd      ekont=1.0d0
8768       if (l.eq.j+1) then
8769         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8770         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8771         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8772         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8773         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8774         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8775       else
8776         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8777         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8778         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8779         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8780         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8781           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8782         else
8783           eello6_5=0.0d0
8784         endif
8785         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8786       endif
8787 C If turn contributions are considered, they will be handled separately.
8788       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8789 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8790 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8791 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8792 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8793 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8794 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8795 cd      goto 1112
8796       if (j.lt.nres-1) then
8797         j1=j+1
8798         j2=j-1
8799       else
8800         j1=j-1
8801         j2=j-2
8802       endif
8803       if (l.lt.nres-1) then
8804         l1=l+1
8805         l2=l-1
8806       else
8807         l1=l-1
8808         l2=l-2
8809       endif
8810       do ll=1,3
8811 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8812 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8813 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8814 cgrad        ghalf=0.5d0*ggg1(ll)
8815 cd        ghalf=0.0d0
8816         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8817         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8818         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8819         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8820         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8821         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8822         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8823         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8824 cgrad        ghalf=0.5d0*ggg2(ll)
8825 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8826 cd        ghalf=0.0d0
8827         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8828         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8829         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8830         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8831         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8832         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8833       enddo
8834 cd      goto 1112
8835 cgrad      do m=i+1,j-1
8836 cgrad        do ll=1,3
8837 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8838 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8839 cgrad        enddo
8840 cgrad      enddo
8841 cgrad      do m=k+1,l-1
8842 cgrad        do ll=1,3
8843 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8844 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8845 cgrad        enddo
8846 cgrad      enddo
8847 cgrad1112  continue
8848 cgrad      do m=i+2,j2
8849 cgrad        do ll=1,3
8850 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8851 cgrad        enddo
8852 cgrad      enddo
8853 cgrad      do m=k+2,l2
8854 cgrad        do ll=1,3
8855 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8856 cgrad        enddo
8857 cgrad      enddo
8858 cd      do iii=1,nres-3
8859 cd        write (2,*) iii,g_corr6_loc(iii)
8860 cd      enddo
8861       eello6=ekont*eel6
8862 cd      write (2,*) 'ekont',ekont
8863 cd      write (iout,*) 'eello6',ekont*eel6
8864       return
8865       end
8866 c--------------------------------------------------------------------------
8867       double precision function eello6_graph1(i,j,k,l,imat,swap)
8868       implicit real*8 (a-h,o-z)
8869       include 'DIMENSIONS'
8870       include 'COMMON.IOUNITS'
8871       include 'COMMON.CHAIN'
8872       include 'COMMON.DERIV'
8873       include 'COMMON.INTERACT'
8874       include 'COMMON.CONTACTS'
8875       include 'COMMON.TORSION'
8876       include 'COMMON.VAR'
8877       include 'COMMON.GEO'
8878       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8879       logical swap
8880       logical lprn
8881       common /kutas/ lprn
8882 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8883 C
8884 C      Parallel       Antiparallel
8885 C
8886 C          o             o
8887 C         /l\           /j\
8888 C        /   \         /   \
8889 C       /| o |         | o |\
8890 C     \ j|/k\|  /   \  |/k\|l /
8891 C      \ /   \ /     \ /   \ /
8892 C       o     o       o     o
8893 C       i             i
8894 C
8895 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8896       itk=itortyp(itype(k))
8897       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8898       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8899       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8900       call transpose2(EUgC(1,1,k),auxmat(1,1))
8901       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8902       vv1(1)=pizda1(1,1)-pizda1(2,2)
8903       vv1(2)=pizda1(1,2)+pizda1(2,1)
8904       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8905       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8906       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8907       s5=scalar2(vv(1),Dtobr2(1,i))
8908 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8909       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8910       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8911      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8912      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8913      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8914      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8915      & +scalar2(vv(1),Dtobr2der(1,i)))
8916       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8917       vv1(1)=pizda1(1,1)-pizda1(2,2)
8918       vv1(2)=pizda1(1,2)+pizda1(2,1)
8919       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8920       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8921       if (l.eq.j+1) then
8922         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8923      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8924      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8925      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8926      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8927       else
8928         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8929      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8930      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8931      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8932      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8933       endif
8934       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8935       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8936       vv1(1)=pizda1(1,1)-pizda1(2,2)
8937       vv1(2)=pizda1(1,2)+pizda1(2,1)
8938       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8939      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8940      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8941      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8942       do iii=1,2
8943         if (swap) then
8944           ind=3-iii
8945         else
8946           ind=iii
8947         endif
8948         do kkk=1,5
8949           do lll=1,3
8950             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8951             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8952             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8953             call transpose2(EUgC(1,1,k),auxmat(1,1))
8954             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8955      &        pizda1(1,1))
8956             vv1(1)=pizda1(1,1)-pizda1(2,2)
8957             vv1(2)=pizda1(1,2)+pizda1(2,1)
8958             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8959             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8960      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8961             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8962      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8963             s5=scalar2(vv(1),Dtobr2(1,i))
8964             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8965           enddo
8966         enddo
8967       enddo
8968       return
8969       end
8970 c----------------------------------------------------------------------------
8971       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8972       implicit real*8 (a-h,o-z)
8973       include 'DIMENSIONS'
8974       include 'COMMON.IOUNITS'
8975       include 'COMMON.CHAIN'
8976       include 'COMMON.DERIV'
8977       include 'COMMON.INTERACT'
8978       include 'COMMON.CONTACTS'
8979       include 'COMMON.TORSION'
8980       include 'COMMON.VAR'
8981       include 'COMMON.GEO'
8982       logical swap
8983       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8984      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8985       logical lprn
8986       common /kutas/ lprn
8987 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8988 C                                                                              C
8989 C      Parallel       Antiparallel                                             C
8990 C                                                                              C
8991 C          o             o                                                     C
8992 C     \   /l\           /j\   /                                                C
8993 C      \ /   \         /   \ /                                                 C
8994 C       o| o |         | o |o                                                  C
8995 C     \ j|/k\|      \  |/k\|l                                                  C
8996 C      \ /   \       \ /   \                                                   C
8997 C       o             o                                                        C
8998 C       i             i                                                        C
8999 C                                                                              C
9000 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9001 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9002 C AL 7/4/01 s1 would occur in the sixth-order moment,
9003 C           but not in a cluster cumulant
9004 #ifdef MOMENT
9005       s1=dip(1,jj,i)*dip(1,kk,k)
9006 #endif
9007       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9008       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9009       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9010       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9011       call transpose2(EUg(1,1,k),auxmat(1,1))
9012       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9013       vv(1)=pizda(1,1)-pizda(2,2)
9014       vv(2)=pizda(1,2)+pizda(2,1)
9015       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9016 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9017 #ifdef MOMENT
9018       eello6_graph2=-(s1+s2+s3+s4)
9019 #else
9020       eello6_graph2=-(s2+s3+s4)
9021 #endif
9022 c      eello6_graph2=-s3
9023 C Derivatives in gamma(i-1)
9024       if (i.gt.1) then
9025 #ifdef MOMENT
9026         s1=dipderg(1,jj,i)*dip(1,kk,k)
9027 #endif
9028         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9029         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9030         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9031         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9032 #ifdef MOMENT
9033         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9034 #else
9035         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9036 #endif
9037 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9038       endif
9039 C Derivatives in gamma(k-1)
9040 #ifdef MOMENT
9041       s1=dip(1,jj,i)*dipderg(1,kk,k)
9042 #endif
9043       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9044       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9045       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9046       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9047       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9048       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9049       vv(1)=pizda(1,1)-pizda(2,2)
9050       vv(2)=pizda(1,2)+pizda(2,1)
9051       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9052 #ifdef MOMENT
9053       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9054 #else
9055       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9056 #endif
9057 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9058 C Derivatives in gamma(j-1) or gamma(l-1)
9059       if (j.gt.1) then
9060 #ifdef MOMENT
9061         s1=dipderg(3,jj,i)*dip(1,kk,k)
9062 #endif
9063         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9064         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9065         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9066         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9067         vv(1)=pizda(1,1)-pizda(2,2)
9068         vv(2)=pizda(1,2)+pizda(2,1)
9069         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9070 #ifdef MOMENT
9071         if (swap) then
9072           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9073         else
9074           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9075         endif
9076 #endif
9077         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9078 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9079       endif
9080 C Derivatives in gamma(l-1) or gamma(j-1)
9081       if (l.gt.1) then
9082 #ifdef MOMENT
9083         s1=dip(1,jj,i)*dipderg(3,kk,k)
9084 #endif
9085         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9086         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9087         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9088         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9089         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9090         vv(1)=pizda(1,1)-pizda(2,2)
9091         vv(2)=pizda(1,2)+pizda(2,1)
9092         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9093 #ifdef MOMENT
9094         if (swap) then
9095           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9096         else
9097           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9098         endif
9099 #endif
9100         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9101 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9102       endif
9103 C Cartesian derivatives.
9104       if (lprn) then
9105         write (2,*) 'In eello6_graph2'
9106         do iii=1,2
9107           write (2,*) 'iii=',iii
9108           do kkk=1,5
9109             write (2,*) 'kkk=',kkk
9110             do jjj=1,2
9111               write (2,'(3(2f10.5),5x)')
9112      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9113             enddo
9114           enddo
9115         enddo
9116       endif
9117       do iii=1,2
9118         do kkk=1,5
9119           do lll=1,3
9120 #ifdef MOMENT
9121             if (iii.eq.1) then
9122               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9123             else
9124               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9125             endif
9126 #endif
9127             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9128      &        auxvec(1))
9129             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9130             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9131      &        auxvec(1))
9132             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9133             call transpose2(EUg(1,1,k),auxmat(1,1))
9134             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9135      &        pizda(1,1))
9136             vv(1)=pizda(1,1)-pizda(2,2)
9137             vv(2)=pizda(1,2)+pizda(2,1)
9138             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9139 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9140 #ifdef MOMENT
9141             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9142 #else
9143             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9144 #endif
9145             if (swap) then
9146               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9147             else
9148               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9149             endif
9150           enddo
9151         enddo
9152       enddo
9153       return
9154       end
9155 c----------------------------------------------------------------------------
9156       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9157       implicit real*8 (a-h,o-z)
9158       include 'DIMENSIONS'
9159       include 'COMMON.IOUNITS'
9160       include 'COMMON.CHAIN'
9161       include 'COMMON.DERIV'
9162       include 'COMMON.INTERACT'
9163       include 'COMMON.CONTACTS'
9164       include 'COMMON.TORSION'
9165       include 'COMMON.VAR'
9166       include 'COMMON.GEO'
9167       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9168       logical swap
9169 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9170 C                                                                              C
9171 C      Parallel       Antiparallel                                             C
9172 C                                                                              C
9173 C          o             o                                                     C
9174 C         /l\   /   \   /j\                                                    C
9175 C        /   \ /     \ /   \                                                   C
9176 C       /| o |o       o| o |\                                                  C
9177 C       j|/k\|  /      |/k\|l /                                                C
9178 C        /   \ /       /   \ /                                                 C
9179 C       /     o       /     o                                                  C
9180 C       i             i                                                        C
9181 C                                                                              C
9182 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9183 C
9184 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9185 C           energy moment and not to the cluster cumulant.
9186       iti=itortyp(itype(i))
9187       if (j.lt.nres-1) then
9188         itj1=itortyp(itype(j+1))
9189       else
9190         itj1=ntortyp+1
9191       endif
9192       itk=itortyp(itype(k))
9193       itk1=itortyp(itype(k+1))
9194       if (l.lt.nres-1) then
9195         itl1=itortyp(itype(l+1))
9196       else
9197         itl1=ntortyp+1
9198       endif
9199 #ifdef MOMENT
9200       s1=dip(4,jj,i)*dip(4,kk,k)
9201 #endif
9202       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9203       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9204       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9205       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9206       call transpose2(EE(1,1,itk),auxmat(1,1))
9207       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9208       vv(1)=pizda(1,1)+pizda(2,2)
9209       vv(2)=pizda(2,1)-pizda(1,2)
9210       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9211 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9212 cd     & "sum",-(s2+s3+s4)
9213 #ifdef MOMENT
9214       eello6_graph3=-(s1+s2+s3+s4)
9215 #else
9216       eello6_graph3=-(s2+s3+s4)
9217 #endif
9218 c      eello6_graph3=-s4
9219 C Derivatives in gamma(k-1)
9220       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9221       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9222       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9223       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9224 C Derivatives in gamma(l-1)
9225       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9226       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9227       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9228       vv(1)=pizda(1,1)+pizda(2,2)
9229       vv(2)=pizda(2,1)-pizda(1,2)
9230       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9231       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9232 C Cartesian derivatives.
9233       do iii=1,2
9234         do kkk=1,5
9235           do lll=1,3
9236 #ifdef MOMENT
9237             if (iii.eq.1) then
9238               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9239             else
9240               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9241             endif
9242 #endif
9243             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
9244      &        auxvec(1))
9245             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9246             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
9247      &        auxvec(1))
9248             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9249             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9250      &        pizda(1,1))
9251             vv(1)=pizda(1,1)+pizda(2,2)
9252             vv(2)=pizda(2,1)-pizda(1,2)
9253             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9254 #ifdef MOMENT
9255             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9256 #else
9257             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9258 #endif
9259             if (swap) then
9260               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9261             else
9262               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9263             endif
9264 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9265           enddo
9266         enddo
9267       enddo
9268       return
9269       end
9270 c----------------------------------------------------------------------------
9271       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9272       implicit real*8 (a-h,o-z)
9273       include 'DIMENSIONS'
9274       include 'COMMON.IOUNITS'
9275       include 'COMMON.CHAIN'
9276       include 'COMMON.DERIV'
9277       include 'COMMON.INTERACT'
9278       include 'COMMON.CONTACTS'
9279       include 'COMMON.TORSION'
9280       include 'COMMON.VAR'
9281       include 'COMMON.GEO'
9282       include 'COMMON.FFIELD'
9283       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9284      & auxvec1(2),auxmat1(2,2)
9285       logical swap
9286 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9287 C                                                                              C
9288 C      Parallel       Antiparallel                                             C
9289 C                                                                              C
9290 C          o             o                                                     C
9291 C         /l\   /   \   /j\                                                    C
9292 C        /   \ /     \ /   \                                                   C
9293 C       /| o |o       o| o |\                                                  C
9294 C     \ j|/k\|      \  |/k\|l                                                  C
9295 C      \ /   \       \ /   \                                                   C
9296 C       o     \       o     \                                                  C
9297 C       i             i                                                        C
9298 C                                                                              C
9299 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9300 C
9301 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9302 C           energy moment and not to the cluster cumulant.
9303 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9304       iti=itortyp(itype(i))
9305       itj=itortyp(itype(j))
9306       if (j.lt.nres-1) then
9307         itj1=itortyp(itype(j+1))
9308       else
9309         itj1=ntortyp+1
9310       endif
9311       itk=itortyp(itype(k))
9312       if (k.lt.nres-1) then
9313         itk1=itortyp(itype(k+1))
9314       else
9315         itk1=ntortyp+1
9316       endif
9317       itl=itortyp(itype(l))
9318       if (l.lt.nres-1) then
9319         itl1=itortyp(itype(l+1))
9320       else
9321         itl1=ntortyp+1
9322       endif
9323 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9324 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9325 cd     & ' itl',itl,' itl1',itl1
9326 #ifdef MOMENT
9327       if (imat.eq.1) then
9328         s1=dip(3,jj,i)*dip(3,kk,k)
9329       else
9330         s1=dip(2,jj,j)*dip(2,kk,l)
9331       endif
9332 #endif
9333       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9334       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9335       if (j.eq.l+1) then
9336         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9337         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9338       else
9339         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9340         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9341       endif
9342       call transpose2(EUg(1,1,k),auxmat(1,1))
9343       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9344       vv(1)=pizda(1,1)-pizda(2,2)
9345       vv(2)=pizda(2,1)+pizda(1,2)
9346       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9347 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9348 #ifdef MOMENT
9349       eello6_graph4=-(s1+s2+s3+s4)
9350 #else
9351       eello6_graph4=-(s2+s3+s4)
9352 #endif
9353 C Derivatives in gamma(i-1)
9354       if (i.gt.1) then
9355 #ifdef MOMENT
9356         if (imat.eq.1) then
9357           s1=dipderg(2,jj,i)*dip(3,kk,k)
9358         else
9359           s1=dipderg(4,jj,j)*dip(2,kk,l)
9360         endif
9361 #endif
9362         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9363         if (j.eq.l+1) then
9364           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9365           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9366         else
9367           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9368           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9369         endif
9370         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9371         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9372 cd          write (2,*) 'turn6 derivatives'
9373 #ifdef MOMENT
9374           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9375 #else
9376           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9377 #endif
9378         else
9379 #ifdef MOMENT
9380           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9381 #else
9382           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9383 #endif
9384         endif
9385       endif
9386 C Derivatives in gamma(k-1)
9387 #ifdef MOMENT
9388       if (imat.eq.1) then
9389         s1=dip(3,jj,i)*dipderg(2,kk,k)
9390       else
9391         s1=dip(2,jj,j)*dipderg(4,kk,l)
9392       endif
9393 #endif
9394       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9395       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9396       if (j.eq.l+1) then
9397         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9398         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9399       else
9400         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9401         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9402       endif
9403       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9404       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9405       vv(1)=pizda(1,1)-pizda(2,2)
9406       vv(2)=pizda(2,1)+pizda(1,2)
9407       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9408       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9409 #ifdef MOMENT
9410         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9411 #else
9412         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9413 #endif
9414       else
9415 #ifdef MOMENT
9416         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9417 #else
9418         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9419 #endif
9420       endif
9421 C Derivatives in gamma(j-1) or gamma(l-1)
9422       if (l.eq.j+1 .and. l.gt.1) then
9423         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9424         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9425         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9426         vv(1)=pizda(1,1)-pizda(2,2)
9427         vv(2)=pizda(2,1)+pizda(1,2)
9428         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9429         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9430       else if (j.gt.1) then
9431         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9432         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9433         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9434         vv(1)=pizda(1,1)-pizda(2,2)
9435         vv(2)=pizda(2,1)+pizda(1,2)
9436         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9437         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9438           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9439         else
9440           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9441         endif
9442       endif
9443 C Cartesian derivatives.
9444       do iii=1,2
9445         do kkk=1,5
9446           do lll=1,3
9447 #ifdef MOMENT
9448             if (iii.eq.1) then
9449               if (imat.eq.1) then
9450                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9451               else
9452                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9453               endif
9454             else
9455               if (imat.eq.1) then
9456                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9457               else
9458                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9459               endif
9460             endif
9461 #endif
9462             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9463      &        auxvec(1))
9464             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9465             if (j.eq.l+1) then
9466               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9467      &          b1(1,itj1),auxvec(1))
9468               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9469             else
9470               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9471      &          b1(1,itl1),auxvec(1))
9472               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9473             endif
9474             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9475      &        pizda(1,1))
9476             vv(1)=pizda(1,1)-pizda(2,2)
9477             vv(2)=pizda(2,1)+pizda(1,2)
9478             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9479             if (swap) then
9480               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9481 #ifdef MOMENT
9482                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9483      &             -(s1+s2+s4)
9484 #else
9485                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9486      &             -(s2+s4)
9487 #endif
9488                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9489               else
9490 #ifdef MOMENT
9491                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9492 #else
9493                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9494 #endif
9495                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9496               endif
9497             else
9498 #ifdef MOMENT
9499               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9500 #else
9501               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9502 #endif
9503               if (l.eq.j+1) then
9504                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9505               else
9506                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9507               endif
9508             endif
9509           enddo
9510         enddo
9511       enddo
9512       return
9513       end
9514 c----------------------------------------------------------------------------
9515       double precision function eello_turn6(i,jj,kk)
9516       implicit real*8 (a-h,o-z)
9517       include 'DIMENSIONS'
9518       include 'COMMON.IOUNITS'
9519       include 'COMMON.CHAIN'
9520       include 'COMMON.DERIV'
9521       include 'COMMON.INTERACT'
9522       include 'COMMON.CONTACTS'
9523       include 'COMMON.TORSION'
9524       include 'COMMON.VAR'
9525       include 'COMMON.GEO'
9526       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9527      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9528      &  ggg1(3),ggg2(3)
9529       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9530      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9531 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9532 C           the respective energy moment and not to the cluster cumulant.
9533       s1=0.0d0
9534       s8=0.0d0
9535       s13=0.0d0
9536 c
9537       eello_turn6=0.0d0
9538       j=i+4
9539       k=i+1
9540       l=i+3
9541       iti=itortyp(itype(i))
9542       itk=itortyp(itype(k))
9543       itk1=itortyp(itype(k+1))
9544       itl=itortyp(itype(l))
9545       itj=itortyp(itype(j))
9546 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9547 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9548 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9549 cd        eello6=0.0d0
9550 cd        return
9551 cd      endif
9552 cd      write (iout,*)
9553 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9554 cd     &   ' and',k,l
9555 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9556       do iii=1,2
9557         do kkk=1,5
9558           do lll=1,3
9559             derx_turn(lll,kkk,iii)=0.0d0
9560           enddo
9561         enddo
9562       enddo
9563 cd      eij=1.0d0
9564 cd      ekl=1.0d0
9565 cd      ekont=1.0d0
9566       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9567 cd      eello6_5=0.0d0
9568 cd      write (2,*) 'eello6_5',eello6_5
9569 #ifdef MOMENT
9570       call transpose2(AEA(1,1,1),auxmat(1,1))
9571       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9572       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9573       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9574 #endif
9575       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9576       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9577       s2 = scalar2(b1(1,itk),vtemp1(1))
9578 #ifdef MOMENT
9579       call transpose2(AEA(1,1,2),atemp(1,1))
9580       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9581       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9582       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9583 #endif
9584       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9585       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9586       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9587 #ifdef MOMENT
9588       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9589       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9590       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9591       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9592       ss13 = scalar2(b1(1,itk),vtemp4(1))
9593       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9594 #endif
9595 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9596 c      s1=0.0d0
9597 c      s2=0.0d0
9598 c      s8=0.0d0
9599 c      s12=0.0d0
9600 c      s13=0.0d0
9601       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9602 C Derivatives in gamma(i+2)
9603       s1d =0.0d0
9604       s8d =0.0d0
9605 #ifdef MOMENT
9606       call transpose2(AEA(1,1,1),auxmatd(1,1))
9607       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9608       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9609       call transpose2(AEAderg(1,1,2),atempd(1,1))
9610       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9611       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9612 #endif
9613       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9614       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9615       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9616 c      s1d=0.0d0
9617 c      s2d=0.0d0
9618 c      s8d=0.0d0
9619 c      s12d=0.0d0
9620 c      s13d=0.0d0
9621       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9622 C Derivatives in gamma(i+3)
9623 #ifdef MOMENT
9624       call transpose2(AEA(1,1,1),auxmatd(1,1))
9625       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9626       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9627       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9628 #endif
9629       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9630       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9631       s2d = scalar2(b1(1,itk),vtemp1d(1))
9632 #ifdef MOMENT
9633       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9634       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9635 #endif
9636       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9637 #ifdef MOMENT
9638       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9639       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9640       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9641 #endif
9642 c      s1d=0.0d0
9643 c      s2d=0.0d0
9644 c      s8d=0.0d0
9645 c      s12d=0.0d0
9646 c      s13d=0.0d0
9647 #ifdef MOMENT
9648       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9649      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9650 #else
9651       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9652      &               -0.5d0*ekont*(s2d+s12d)
9653 #endif
9654 C Derivatives in gamma(i+4)
9655       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9656       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9657       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9658 #ifdef MOMENT
9659       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9660       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9661       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9662 #endif
9663 c      s1d=0.0d0
9664 c      s2d=0.0d0
9665 c      s8d=0.0d0
9666 C      s12d=0.0d0
9667 c      s13d=0.0d0
9668 #ifdef MOMENT
9669       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9670 #else
9671       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9672 #endif
9673 C Derivatives in gamma(i+5)
9674 #ifdef MOMENT
9675       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9676       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9677       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9678 #endif
9679       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9680       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9681       s2d = scalar2(b1(1,itk),vtemp1d(1))
9682 #ifdef MOMENT
9683       call transpose2(AEA(1,1,2),atempd(1,1))
9684       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9685       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9686 #endif
9687       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9688       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9689 #ifdef MOMENT
9690       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9691       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9692       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9693 #endif
9694 c      s1d=0.0d0
9695 c      s2d=0.0d0
9696 c      s8d=0.0d0
9697 c      s12d=0.0d0
9698 c      s13d=0.0d0
9699 #ifdef MOMENT
9700       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9701      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9702 #else
9703       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9704      &               -0.5d0*ekont*(s2d+s12d)
9705 #endif
9706 C Cartesian derivatives
9707       do iii=1,2
9708         do kkk=1,5
9709           do lll=1,3
9710 #ifdef MOMENT
9711             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9712             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9713             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9714 #endif
9715             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9716             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9717      &          vtemp1d(1))
9718             s2d = scalar2(b1(1,itk),vtemp1d(1))
9719 #ifdef MOMENT
9720             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9721             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9722             s8d = -(atempd(1,1)+atempd(2,2))*
9723      &           scalar2(cc(1,1,itl),vtemp2(1))
9724 #endif
9725             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9726      &           auxmatd(1,1))
9727             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9728             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9729 c      s1d=0.0d0
9730 c      s2d=0.0d0
9731 c      s8d=0.0d0
9732 c      s12d=0.0d0
9733 c      s13d=0.0d0
9734 #ifdef MOMENT
9735             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9736      &        - 0.5d0*(s1d+s2d)
9737 #else
9738             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9739      &        - 0.5d0*s2d
9740 #endif
9741 #ifdef MOMENT
9742             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9743      &        - 0.5d0*(s8d+s12d)
9744 #else
9745             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9746      &        - 0.5d0*s12d
9747 #endif
9748           enddo
9749         enddo
9750       enddo
9751 #ifdef MOMENT
9752       do kkk=1,5
9753         do lll=1,3
9754           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9755      &      achuj_tempd(1,1))
9756           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9757           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9758           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9759           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9760           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9761      &      vtemp4d(1))
9762           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9763           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9764           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9765         enddo
9766       enddo
9767 #endif
9768 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9769 cd     &  16*eel_turn6_num
9770 cd      goto 1112
9771       if (j.lt.nres-1) then
9772         j1=j+1
9773         j2=j-1
9774       else
9775         j1=j-1
9776         j2=j-2
9777       endif
9778       if (l.lt.nres-1) then
9779         l1=l+1
9780         l2=l-1
9781       else
9782         l1=l-1
9783         l2=l-2
9784       endif
9785       do ll=1,3
9786 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9787 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9788 cgrad        ghalf=0.5d0*ggg1(ll)
9789 cd        ghalf=0.0d0
9790         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9791         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9792         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9793      &    +ekont*derx_turn(ll,2,1)
9794         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9795         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9796      &    +ekont*derx_turn(ll,4,1)
9797         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9798         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9799         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9800 cgrad        ghalf=0.5d0*ggg2(ll)
9801 cd        ghalf=0.0d0
9802         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9803      &    +ekont*derx_turn(ll,2,2)
9804         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9805         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9806      &    +ekont*derx_turn(ll,4,2)
9807         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9808         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9809         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9810       enddo
9811 cd      goto 1112
9812 cgrad      do m=i+1,j-1
9813 cgrad        do ll=1,3
9814 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9815 cgrad        enddo
9816 cgrad      enddo
9817 cgrad      do m=k+1,l-1
9818 cgrad        do ll=1,3
9819 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9820 cgrad        enddo
9821 cgrad      enddo
9822 cgrad1112  continue
9823 cgrad      do m=i+2,j2
9824 cgrad        do ll=1,3
9825 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9826 cgrad        enddo
9827 cgrad      enddo
9828 cgrad      do m=k+2,l2
9829 cgrad        do ll=1,3
9830 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9831 cgrad        enddo
9832 cgrad      enddo
9833 cd      do iii=1,nres-3
9834 cd        write (2,*) iii,g_corr6_loc(iii)
9835 cd      enddo
9836       eello_turn6=ekont*eel_turn6
9837 cd      write (2,*) 'ekont',ekont
9838 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9839       return
9840       end
9841
9842 C-----------------------------------------------------------------------------
9843       double precision function scalar(u,v)
9844 !DIR$ INLINEALWAYS scalar
9845 #ifndef OSF
9846 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9847 #endif
9848       implicit none
9849       double precision u(3),v(3)
9850 cd      double precision sc
9851 cd      integer i
9852 cd      sc=0.0d0
9853 cd      do i=1,3
9854 cd        sc=sc+u(i)*v(i)
9855 cd      enddo
9856 cd      scalar=sc
9857
9858       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9859       return
9860       end
9861 crc-------------------------------------------------
9862       SUBROUTINE MATVEC2(A1,V1,V2)
9863 !DIR$ INLINEALWAYS MATVEC2
9864 #ifndef OSF
9865 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9866 #endif
9867       implicit real*8 (a-h,o-z)
9868       include 'DIMENSIONS'
9869       DIMENSION A1(2,2),V1(2),V2(2)
9870 c      DO 1 I=1,2
9871 c        VI=0.0
9872 c        DO 3 K=1,2
9873 c    3     VI=VI+A1(I,K)*V1(K)
9874 c        Vaux(I)=VI
9875 c    1 CONTINUE
9876
9877       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9878       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9879
9880       v2(1)=vaux1
9881       v2(2)=vaux2
9882       END
9883 C---------------------------------------
9884       SUBROUTINE MATMAT2(A1,A2,A3)
9885 #ifndef OSF
9886 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9887 #endif
9888       implicit real*8 (a-h,o-z)
9889       include 'DIMENSIONS'
9890       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9891 c      DIMENSION AI3(2,2)
9892 c        DO  J=1,2
9893 c          A3IJ=0.0
9894 c          DO K=1,2
9895 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9896 c          enddo
9897 c          A3(I,J)=A3IJ
9898 c       enddo
9899 c      enddo
9900
9901       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9902       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9903       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9904       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9905
9906       A3(1,1)=AI3_11
9907       A3(2,1)=AI3_21
9908       A3(1,2)=AI3_12
9909       A3(2,2)=AI3_22
9910       END
9911
9912 c-------------------------------------------------------------------------
9913       double precision function scalar2(u,v)
9914 !DIR$ INLINEALWAYS scalar2
9915       implicit none
9916       double precision u(2),v(2)
9917       double precision sc
9918       integer i
9919       scalar2=u(1)*v(1)+u(2)*v(2)
9920       return
9921       end
9922
9923 C-----------------------------------------------------------------------------
9924
9925       subroutine transpose2(a,at)
9926 !DIR$ INLINEALWAYS transpose2
9927 #ifndef OSF
9928 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9929 #endif
9930       implicit none
9931       double precision a(2,2),at(2,2)
9932       at(1,1)=a(1,1)
9933       at(1,2)=a(2,1)
9934       at(2,1)=a(1,2)
9935       at(2,2)=a(2,2)
9936       return
9937       end
9938 c--------------------------------------------------------------------------
9939       subroutine transpose(n,a,at)
9940       implicit none
9941       integer n,i,j
9942       double precision a(n,n),at(n,n)
9943       do i=1,n
9944         do j=1,n
9945           at(j,i)=a(i,j)
9946         enddo
9947       enddo
9948       return
9949       end
9950 C---------------------------------------------------------------------------
9951       subroutine prodmat3(a1,a2,kk,transp,prod)
9952 !DIR$ INLINEALWAYS prodmat3
9953 #ifndef OSF
9954 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9955 #endif
9956       implicit none
9957       integer i,j
9958       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9959       logical transp
9960 crc      double precision auxmat(2,2),prod_(2,2)
9961
9962       if (transp) then
9963 crc        call transpose2(kk(1,1),auxmat(1,1))
9964 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9965 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9966
9967            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9968      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9969            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9970      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9971            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9972      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9973            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9974      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9975
9976       else
9977 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9978 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9979
9980            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9981      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9982            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9983      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9984            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9985      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9986            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9987      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9988
9989       endif
9990 c      call transpose2(a2(1,1),a2t(1,1))
9991
9992 crc      print *,transp
9993 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9994 crc      print *,((prod(i,j),i=1,2),j=1,2)
9995
9996       return
9997       end
9998