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 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4369 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4370       if (link_end.eq.0) return
4371       do i=link_start,link_end
4372 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4373 C CA-CA distance used in regularization of structure.
4374         ii=ihpb(i)
4375         jj=jhpb(i)
4376 C iii and jjj point to the residues for which the distance is assigned.
4377         if (ii.gt.nres) then
4378           iii=ii-nres
4379           jjj=jj-nres
4380         else
4381           iii=ii
4382           jjj=jj
4383         endif
4384 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4385 c     &    dhpb(i),dhpb1(i),forcon(i)
4386 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4387 C    distance and angle dependent SS bond potential.
4388 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4389 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4390         if (.not.dyn_ss .and. i.le.nss) then
4391 C 15/02/13 CC dynamic SSbond - additional check
4392          if (ii.gt.nres
4393      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4394           call ssbond_ene(iii,jjj,eij)
4395           ehpb=ehpb+2*eij
4396          endif
4397 cd          write (iout,*) "eij",eij
4398         else if (ii.gt.nres .and. jj.gt.nres) then
4399 c Restraints from contact prediction
4400           dd=dist(ii,jj)
4401           if (constr_dist.eq.11) then
4402             ehpb=ehpb+fordepth(i)**4.0d0
4403      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4404             fac=fordepth(i)**4.0d0
4405      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4406           if (energy_dec) write (iout,'(a6,2i5,f15.6,2f8.3)')
4407      &     "edisl",ii,jj,
4408      &     fordepth(i)**4.0d0*rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)),
4409      &     fordepth(i),dd
4410            else
4411           if (dhpb1(i).gt.0.0d0) then
4412             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4413             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4414 c            write (iout,*) "beta nmr",
4415 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4416           else
4417             dd=dist(ii,jj)
4418             rdis=dd-dhpb(i)
4419 C Get the force constant corresponding to this distance.
4420             waga=forcon(i)
4421 C Calculate the contribution to energy.
4422             ehpb=ehpb+waga*rdis*rdis
4423 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4424 C
4425 C Evaluate gradient.
4426 C
4427             fac=waga*rdis/dd
4428           endif
4429           endif
4430           do j=1,3
4431             ggg(j)=fac*(c(j,jj)-c(j,ii))
4432           enddo
4433           do j=1,3
4434             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4435             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4436           enddo
4437           do k=1,3
4438             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4439             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4440           enddo
4441         else
4442 C Calculate the distance between the two points and its difference from the
4443 C target distance.
4444           dd=dist(ii,jj)
4445          if (constr_dist.eq.11) then
4446             ehpb=ehpb+fordepth(i)**4.0d0
4447      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4448             fac=fordepth(i)**4.0d0
4449      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4450           if (energy_dec) write (iout,'(a6,2i5,f15.6,2f8.3)')
4451      7     "edisl",ii,jj,
4452      &     fordepth(i)**4.0d0*rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i)),
4453      &     fordepth(i),dd
4454 c          if (energy_dec)
4455 c     &      write (iout,*) fac
4456          else
4457           if (dhpb1(i).gt.0.0d0) then
4458             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4459             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4460 c            write (iout,*) "alph nmr",
4461 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4462           else
4463             rdis=dd-dhpb(i)
4464 C Get the force constant corresponding to this distance.
4465             waga=forcon(i)
4466 C Calculate the contribution to energy.
4467             ehpb=ehpb+waga*rdis*rdis
4468 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4469 C
4470 C Evaluate gradient.
4471 C
4472             fac=waga*rdis/dd
4473           endif
4474          endif
4475 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4476 cd   &   ' waga=',waga,' fac=',fac
4477             do j=1,3
4478               ggg(j)=fac*(c(j,jj)-c(j,ii))
4479             enddo
4480 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4481 C If this is a SC-SC distance, we need to calculate the contributions to the
4482 C Cartesian gradient in the SC vectors (ghpbx).
4483           if (iii.lt.ii) then
4484           do j=1,3
4485             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4486             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4487           enddo
4488           endif
4489 cgrad        do j=iii,jjj-1
4490 cgrad          do k=1,3
4491 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4492 cgrad          enddo
4493 cgrad        enddo
4494           do k=1,3
4495             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4496             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4497           enddo
4498         endif
4499       enddo
4500       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
4501 c      do i=1,nres
4502 c        write (iout,*) "ghpbc",i,(ghpbc(j,i),j=1,3)
4503 c      enddo
4504       return
4505       end
4506 C--------------------------------------------------------------------------
4507       subroutine ssbond_ene(i,j,eij)
4508 C
4509 C Calculate the distance and angle dependent SS-bond potential energy
4510 C using a free-energy function derived based on RHF/6-31G** ab initio
4511 C calculations of diethyl disulfide.
4512 C
4513 C A. Liwo and U. Kozlowska, 11/24/03
4514 C
4515       implicit real*8 (a-h,o-z)
4516       include 'DIMENSIONS'
4517       include 'COMMON.SBRIDGE'
4518       include 'COMMON.CHAIN'
4519       include 'COMMON.DERIV'
4520       include 'COMMON.LOCAL'
4521       include 'COMMON.INTERACT'
4522       include 'COMMON.VAR'
4523       include 'COMMON.IOUNITS'
4524       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4525       itypi=itype(i)
4526       xi=c(1,nres+i)
4527       yi=c(2,nres+i)
4528       zi=c(3,nres+i)
4529       dxi=dc_norm(1,nres+i)
4530       dyi=dc_norm(2,nres+i)
4531       dzi=dc_norm(3,nres+i)
4532 c      dsci_inv=dsc_inv(itypi)
4533       dsci_inv=vbld_inv(nres+i)
4534       itypj=itype(j)
4535 c      dscj_inv=dsc_inv(itypj)
4536       dscj_inv=vbld_inv(nres+j)
4537       xj=c(1,nres+j)-xi
4538       yj=c(2,nres+j)-yi
4539       zj=c(3,nres+j)-zi
4540       dxj=dc_norm(1,nres+j)
4541       dyj=dc_norm(2,nres+j)
4542       dzj=dc_norm(3,nres+j)
4543       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4544       rij=dsqrt(rrij)
4545       erij(1)=xj*rij
4546       erij(2)=yj*rij
4547       erij(3)=zj*rij
4548       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4549       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4550       om12=dxi*dxj+dyi*dyj+dzi*dzj
4551       do k=1,3
4552         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4553         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4554       enddo
4555       rij=1.0d0/rij
4556       deltad=rij-d0cm
4557       deltat1=1.0d0-om1
4558       deltat2=1.0d0+om2
4559       deltat12=om2-om1+2.0d0
4560       cosphi=om12-om1*om2
4561       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4562      &  +akct*deltad*deltat12+ebr
4563      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4564 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4565 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4566 c     &  " deltat12",deltat12," eij",eij
4567       ed=2*akcm*deltad+akct*deltat12
4568       pom1=akct*deltad
4569       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4570       eom1=-2*akth*deltat1-pom1-om2*pom2
4571       eom2= 2*akth*deltat2+pom1-om1*pom2
4572       eom12=pom2
4573       do k=1,3
4574         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4575         ghpbx(k,i)=ghpbx(k,i)-ggk
4576      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4577      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4578         ghpbx(k,j)=ghpbx(k,j)+ggk
4579      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4580      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4581         ghpbc(k,i)=ghpbc(k,i)-ggk
4582         ghpbc(k,j)=ghpbc(k,j)+ggk
4583       enddo
4584 C
4585 C Calculate the components of the gradient in DC and X
4586 C
4587 cgrad      do k=i,j-1
4588 cgrad        do l=1,3
4589 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4590 cgrad        enddo
4591 cgrad      enddo
4592       return
4593       end
4594 C--------------------------------------------------------------------------
4595       subroutine ebond(estr)
4596 c
4597 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4598 c
4599       implicit real*8 (a-h,o-z)
4600       include 'DIMENSIONS'
4601       include 'COMMON.LOCAL'
4602       include 'COMMON.GEO'
4603       include 'COMMON.INTERACT'
4604       include 'COMMON.DERIV'
4605       include 'COMMON.VAR'
4606       include 'COMMON.CHAIN'
4607       include 'COMMON.IOUNITS'
4608       include 'COMMON.NAMES'
4609       include 'COMMON.FFIELD'
4610       include 'COMMON.CONTROL'
4611       include 'COMMON.SETUP'
4612       double precision u(3),ud(3)
4613       estr=0.0d0
4614       do i=ibondp_start,ibondp_end
4615         diff = vbld(i)-vbldp0
4616 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4617         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4618      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4619         estr=estr+diff*diff
4620         do j=1,3
4621           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4622         enddo
4623 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4624       enddo
4625       estr=0.5d0*AKP*estr
4626 c
4627 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4628 c
4629       do i=ibond_start,ibond_end
4630         iti=itype(i)
4631         if (iti.ne.10) then
4632           nbi=nbondterm(iti)
4633           if (nbi.eq.1) then
4634             diff=vbld(i+nres)-vbldsc0(1,iti)
4635 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4636 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4637             if (energy_dec)  then
4638               write (iout,*)
4639      &         "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4640      &         AKSC(1,iti),AKSC(1,iti)*diff*diff
4641               call flush(iout)
4642             endif
4643             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4644             do j=1,3
4645               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4646             enddo
4647           else
4648             do j=1,nbi
4649               diff=vbld(i+nres)-vbldsc0(j,iti)
4650               ud(j)=aksc(j,iti)*diff
4651               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4652             enddo
4653             uprod=u(1)
4654             do j=2,nbi
4655               uprod=uprod*u(j)
4656             enddo
4657             usum=0.0d0
4658             usumsqder=0.0d0
4659             do j=1,nbi
4660               uprod1=1.0d0
4661               uprod2=1.0d0
4662               do k=1,nbi
4663                 if (k.ne.j) then
4664                   uprod1=uprod1*u(k)
4665                   uprod2=uprod2*u(k)*u(k)
4666                 endif
4667               enddo
4668               usum=usum+uprod1
4669               usumsqder=usumsqder+ud(j)*uprod2
4670             enddo
4671             estr=estr+uprod/usum
4672             do j=1,3
4673              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4674             enddo
4675           endif
4676         endif
4677       enddo
4678       return
4679       end
4680 #ifdef CRYST_THETA
4681 C--------------------------------------------------------------------------
4682       subroutine ebend(etheta)
4683 C
4684 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4685 C angles gamma and its derivatives in consecutive thetas and gammas.
4686 C
4687       implicit real*8 (a-h,o-z)
4688       include 'DIMENSIONS'
4689       include 'COMMON.LOCAL'
4690       include 'COMMON.GEO'
4691       include 'COMMON.INTERACT'
4692       include 'COMMON.DERIV'
4693       include 'COMMON.VAR'
4694       include 'COMMON.CHAIN'
4695       include 'COMMON.IOUNITS'
4696       include 'COMMON.NAMES'
4697       include 'COMMON.FFIELD'
4698       include 'COMMON.CONTROL'
4699       common /calcthet/ term1,term2,termm,diffak,ratak,
4700      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4701      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4702       double precision y(2),z(2)
4703       delta=0.02d0*pi
4704 c      time11=dexp(-2*time)
4705 c      time12=1.0d0
4706       etheta=0.0D0
4707 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4708       do i=ithet_start,ithet_end
4709 C Zero the energy function and its derivative at 0 or pi.
4710         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4711         it=itype(i-1)
4712         if (i.gt.3) then
4713 #ifdef OSF
4714           phii=phi(i)
4715           if (phii.ne.phii) phii=150.0
4716 #else
4717           phii=phi(i)
4718 #endif
4719           y(1)=dcos(phii)
4720           y(2)=dsin(phii)
4721         else
4722           y(1)=0.0D0
4723           y(2)=0.0D0
4724         endif
4725         if (i.lt.nres) then
4726 #ifdef OSF
4727           phii1=phi(i+1)
4728           if (phii1.ne.phii1) phii1=150.0
4729           phii1=pinorm(phii1)
4730           z(1)=cos(phii1)
4731 #else
4732           phii1=phi(i+1)
4733           z(1)=dcos(phii1)
4734 #endif
4735           z(2)=dsin(phii1)
4736         else
4737           z(1)=0.0D0
4738           z(2)=0.0D0
4739         endif
4740 C Calculate the "mean" value of theta from the part of the distribution
4741 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4742 C In following comments this theta will be referred to as t_c.
4743         thet_pred_mean=0.0d0
4744         do k=1,2
4745           athetk=athet(k,it)
4746           bthetk=bthet(k,it)
4747           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4748         enddo
4749         dthett=thet_pred_mean*ssd
4750         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4751 C Derivatives of the "mean" values in gamma1 and gamma2.
4752         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4753         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4754         if (theta(i).gt.pi-delta) then
4755           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4756      &         E_tc0)
4757           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4758           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4759           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4760      &        E_theta)
4761           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4762      &        E_tc)
4763         else if (theta(i).lt.delta) then
4764           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4765           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4766           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4767      &        E_theta)
4768           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4769           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4770      &        E_tc)
4771         else
4772           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4773      &        E_theta,E_tc)
4774         endif
4775         etheta=etheta+ethetai
4776         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4777      &      'ebend',i,ethetai
4778         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4779         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4780         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4781       enddo
4782 C Ufff.... We've done all this!!!
4783       return
4784       end
4785 C---------------------------------------------------------------------------
4786       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4787      &     E_tc)
4788       implicit real*8 (a-h,o-z)
4789       include 'DIMENSIONS'
4790       include 'COMMON.LOCAL'
4791       include 'COMMON.IOUNITS'
4792       common /calcthet/ term1,term2,termm,diffak,ratak,
4793      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4794      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4795 C Calculate the contributions to both Gaussian lobes.
4796 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4797 C The "polynomial part" of the "standard deviation" of this part of
4798 C the distribution.
4799         sig=polthet(3,it)
4800         do j=2,0,-1
4801           sig=sig*thet_pred_mean+polthet(j,it)
4802         enddo
4803 C Derivative of the "interior part" of the "standard deviation of the"
4804 C gamma-dependent Gaussian lobe in t_c.
4805         sigtc=3*polthet(3,it)
4806         do j=2,1,-1
4807           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4808         enddo
4809         sigtc=sig*sigtc
4810 C Set the parameters of both Gaussian lobes of the distribution.
4811 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4812         fac=sig*sig+sigc0(it)
4813         sigcsq=fac+fac
4814         sigc=1.0D0/sigcsq
4815 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4816         sigsqtc=-4.0D0*sigcsq*sigtc
4817 c       print *,i,sig,sigtc,sigsqtc
4818 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4819         sigtc=-sigtc/(fac*fac)
4820 C Following variable is sigma(t_c)**(-2)
4821         sigcsq=sigcsq*sigcsq
4822         sig0i=sig0(it)
4823         sig0inv=1.0D0/sig0i**2
4824         delthec=thetai-thet_pred_mean
4825         delthe0=thetai-theta0i
4826         term1=-0.5D0*sigcsq*delthec*delthec
4827         term2=-0.5D0*sig0inv*delthe0*delthe0
4828 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4829 C NaNs in taking the logarithm. We extract the largest exponent which is added
4830 C to the energy (this being the log of the distribution) at the end of energy
4831 C term evaluation for this virtual-bond angle.
4832         if (term1.gt.term2) then
4833           termm=term1
4834           term2=dexp(term2-termm)
4835           term1=1.0d0
4836         else
4837           termm=term2
4838           term1=dexp(term1-termm)
4839           term2=1.0d0
4840         endif
4841 C The ratio between the gamma-independent and gamma-dependent lobes of
4842 C the distribution is a Gaussian function of thet_pred_mean too.
4843         diffak=gthet(2,it)-thet_pred_mean
4844         ratak=diffak/gthet(3,it)**2
4845         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4846 C Let's differentiate it in thet_pred_mean NOW.
4847         aktc=ak*ratak
4848 C Now put together the distribution terms to make complete distribution.
4849         termexp=term1+ak*term2
4850         termpre=sigc+ak*sig0i
4851 C Contribution of the bending energy from this theta is just the -log of
4852 C the sum of the contributions from the two lobes and the pre-exponential
4853 C factor. Simple enough, isn't it?
4854         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4855 C NOW the derivatives!!!
4856 C 6/6/97 Take into account the deformation.
4857         E_theta=(delthec*sigcsq*term1
4858      &       +ak*delthe0*sig0inv*term2)/termexp
4859         E_tc=((sigtc+aktc*sig0i)/termpre
4860      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4861      &       aktc*term2)/termexp)
4862       return
4863       end
4864 c-----------------------------------------------------------------------------
4865       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4866       implicit real*8 (a-h,o-z)
4867       include 'DIMENSIONS'
4868       include 'COMMON.LOCAL'
4869       include 'COMMON.IOUNITS'
4870       common /calcthet/ term1,term2,termm,diffak,ratak,
4871      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4872      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4873       delthec=thetai-thet_pred_mean
4874       delthe0=thetai-theta0i
4875 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4876       t3 = thetai-thet_pred_mean
4877       t6 = t3**2
4878       t9 = term1
4879       t12 = t3*sigcsq
4880       t14 = t12+t6*sigsqtc
4881       t16 = 1.0d0
4882       t21 = thetai-theta0i
4883       t23 = t21**2
4884       t26 = term2
4885       t27 = t21*t26
4886       t32 = termexp
4887       t40 = t32**2
4888       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4889      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4890      & *(-t12*t9-ak*sig0inv*t27)
4891       return
4892       end
4893 #else
4894 C--------------------------------------------------------------------------
4895       subroutine ebend(etheta)
4896 C
4897 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4898 C angles gamma and its derivatives in consecutive thetas and gammas.
4899 C ab initio-derived potentials from
4900 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4901 C
4902       implicit real*8 (a-h,o-z)
4903       include 'DIMENSIONS'
4904       include 'COMMON.LOCAL'
4905       include 'COMMON.GEO'
4906       include 'COMMON.INTERACT'
4907       include 'COMMON.DERIV'
4908       include 'COMMON.VAR'
4909       include 'COMMON.CHAIN'
4910       include 'COMMON.IOUNITS'
4911       include 'COMMON.NAMES'
4912       include 'COMMON.FFIELD'
4913       include 'COMMON.CONTROL'
4914       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4915      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4916      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4917      & sinph1ph2(maxdouble,maxdouble)
4918       logical lprn /.false./, lprn1 /.false./
4919       etheta=0.0D0
4920 c      write (iout,*) "EBEND ithet_start",ithet_start,
4921 c     &     " ithet_end",ithet_end
4922       do i=ithet_start,ithet_end
4923         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4924      &(itype(i).eq.ntyp1)) cycle
4925         dethetai=0.0d0
4926         dephii=0.0d0
4927         dephii1=0.0d0
4928         theti2=0.5d0*theta(i)
4929         ityp2=ithetyp(itype(i-1))
4930         do k=1,nntheterm
4931           coskt(k)=dcos(k*theti2)
4932           sinkt(k)=dsin(k*theti2)
4933         enddo
4934 C        if (i.gt.3) then
4935         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4936 #ifdef OSF
4937           phii=phi(i)
4938           if (phii.ne.phii) phii=150.0
4939 #else
4940           phii=phi(i)
4941 #endif
4942           ityp1=ithetyp(itype(i-2))
4943           do k=1,nsingle
4944             cosph1(k)=dcos(k*phii)
4945             sinph1(k)=dsin(k*phii)
4946           enddo
4947         else
4948           phii=0.0d0
4949           ityp1=ithetyp(itype(i-2))
4950           do k=1,nsingle
4951             cosph1(k)=0.0d0
4952             sinph1(k)=0.0d0
4953           enddo
4954         endif
4955         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4956 #ifdef OSF
4957           phii1=phi(i+1)
4958           if (phii1.ne.phii1) phii1=150.0
4959           phii1=pinorm(phii1)
4960 #else
4961           phii1=phi(i+1)
4962 #endif
4963           ityp3=ithetyp(itype(i))
4964           do k=1,nsingle
4965             cosph2(k)=dcos(k*phii1)
4966             sinph2(k)=dsin(k*phii1)
4967           enddo
4968         else
4969           phii1=0.0d0
4970           ityp3=ithetyp(itype(i))
4971           do k=1,nsingle
4972             cosph2(k)=0.0d0
4973             sinph2(k)=0.0d0
4974           enddo
4975         endif
4976         ethetai=aa0thet(ityp1,ityp2,ityp3)
4977         do k=1,ndouble
4978           do l=1,k-1
4979             ccl=cosph1(l)*cosph2(k-l)
4980             ssl=sinph1(l)*sinph2(k-l)
4981             scl=sinph1(l)*cosph2(k-l)
4982             csl=cosph1(l)*sinph2(k-l)
4983             cosph1ph2(l,k)=ccl-ssl
4984             cosph1ph2(k,l)=ccl+ssl
4985             sinph1ph2(l,k)=scl+csl
4986             sinph1ph2(k,l)=scl-csl
4987           enddo
4988         enddo
4989         if (lprn) then
4990         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4991      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4992         write (iout,*) "coskt and sinkt"
4993         do k=1,nntheterm
4994           write (iout,*) k,coskt(k),sinkt(k)
4995         enddo
4996         endif
4997         do k=1,ntheterm
4998           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4999           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
5000      &      *coskt(k)
5001           if (lprn)
5002      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
5003      &     " ethetai",ethetai
5004         enddo
5005         if (lprn) then
5006         write (iout,*) "cosph and sinph"
5007         do k=1,nsingle
5008           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5009         enddo
5010         write (iout,*) "cosph1ph2 and sinph2ph2"
5011         do k=2,ndouble
5012           do l=1,k-1
5013             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5014      &         sinph1ph2(l,k),sinph1ph2(k,l)
5015           enddo
5016         enddo
5017         write(iout,*) "ethetai",ethetai
5018         endif
5019         do m=1,ntheterm2
5020           do k=1,nsingle
5021             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
5022      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
5023      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
5024      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
5025             ethetai=ethetai+sinkt(m)*aux
5026             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5027             dephii=dephii+k*sinkt(m)*(
5028      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
5029      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
5030             dephii1=dephii1+k*sinkt(m)*(
5031      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
5032      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
5033             if (lprn)
5034      &      write (iout,*) "m",m," k",k," bbthet",
5035      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
5036      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
5037      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
5038      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5039           enddo
5040         enddo
5041         if (lprn)
5042      &  write(iout,*) "ethetai",ethetai
5043         do m=1,ntheterm3
5044           do k=2,ndouble
5045             do l=1,k-1
5046               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5047      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
5048      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5049      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
5050               ethetai=ethetai+sinkt(m)*aux
5051               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5052               dephii=dephii+l*sinkt(m)*(
5053      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
5054      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5055      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
5056      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5057               dephii1=dephii1+(k-l)*sinkt(m)*(
5058      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
5059      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
5060      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5061      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5062               if (lprn) then
5063               write (iout,*) "m",m," k",k," l",l," ffthet",
5064      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5065      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5066      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5067      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5068               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5069      &            cosph1ph2(k,l)*sinkt(m),
5070      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5071               endif
5072             enddo
5073           enddo
5074         enddo
5075 10      continue
5076 c        lprn1=.true.
5077         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
5078      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
5079      &   phii1*rad2deg,ethetai
5080 c        lprn1=.false.
5081         etheta=etheta+ethetai
5082         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5083      &      'ebend',i,ethetai
5084         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5085         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5086         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5087       enddo
5088       return
5089       end
5090 #endif
5091 #ifdef CRYST_SC
5092 c-----------------------------------------------------------------------------
5093       subroutine esc(escloc)
5094 C Calculate the local energy of a side chain and its derivatives in the
5095 C corresponding virtual-bond valence angles THETA and the spherical angles
5096 C ALPHA and OMEGA.
5097       implicit real*8 (a-h,o-z)
5098       include 'DIMENSIONS'
5099       include 'COMMON.GEO'
5100       include 'COMMON.LOCAL'
5101       include 'COMMON.VAR'
5102       include 'COMMON.INTERACT'
5103       include 'COMMON.DERIV'
5104       include 'COMMON.CHAIN'
5105       include 'COMMON.IOUNITS'
5106       include 'COMMON.NAMES'
5107       include 'COMMON.FFIELD'
5108       include 'COMMON.CONTROL'
5109       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5110      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5111       common /sccalc/ time11,time12,time112,theti,it,nlobit
5112       delta=0.02d0*pi
5113       escloc=0.0D0
5114 c     write (iout,'(a)') 'ESC'
5115       do i=loc_start,loc_end
5116         it=itype(i)
5117         if (it.eq.10) goto 1
5118         nlobit=nlob(it)
5119 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5120 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5121         theti=theta(i+1)-pipol
5122         x(1)=dtan(theti)
5123         x(2)=alph(i)
5124         x(3)=omeg(i)
5125
5126         if (x(2).gt.pi-delta) then
5127           xtemp(1)=x(1)
5128           xtemp(2)=pi-delta
5129           xtemp(3)=x(3)
5130           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5131           xtemp(2)=pi
5132           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5133           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5134      &        escloci,dersc(2))
5135           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5136      &        ddersc0(1),dersc(1))
5137           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5138      &        ddersc0(3),dersc(3))
5139           xtemp(2)=pi-delta
5140           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5141           xtemp(2)=pi
5142           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5143           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5144      &            dersc0(2),esclocbi,dersc02)
5145           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5146      &            dersc12,dersc01)
5147           call splinthet(x(2),0.5d0*delta,ss,ssd)
5148           dersc0(1)=dersc01
5149           dersc0(2)=dersc02
5150           dersc0(3)=0.0d0
5151           do k=1,3
5152             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5153           enddo
5154           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5155 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5156 c    &             esclocbi,ss,ssd
5157           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5158 c         escloci=esclocbi
5159 c         write (iout,*) escloci
5160         else if (x(2).lt.delta) then
5161           xtemp(1)=x(1)
5162           xtemp(2)=delta
5163           xtemp(3)=x(3)
5164           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5165           xtemp(2)=0.0d0
5166           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5167           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5168      &        escloci,dersc(2))
5169           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5170      &        ddersc0(1),dersc(1))
5171           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5172      &        ddersc0(3),dersc(3))
5173           xtemp(2)=delta
5174           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5175           xtemp(2)=0.0d0
5176           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5177           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5178      &            dersc0(2),esclocbi,dersc02)
5179           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5180      &            dersc12,dersc01)
5181           dersc0(1)=dersc01
5182           dersc0(2)=dersc02
5183           dersc0(3)=0.0d0
5184           call splinthet(x(2),0.5d0*delta,ss,ssd)
5185           do k=1,3
5186             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5187           enddo
5188           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5189 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5190 c    &             esclocbi,ss,ssd
5191           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5192 c         write (iout,*) escloci
5193         else
5194           call enesc(x,escloci,dersc,ddummy,.false.)
5195         endif
5196
5197         escloc=escloc+escloci
5198         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5199      &     'escloc',i,escloci
5200 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5201
5202         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5203      &   wscloc*dersc(1)
5204         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5205         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5206     1   continue
5207       enddo
5208       return
5209       end
5210 C---------------------------------------------------------------------------
5211       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5212       implicit real*8 (a-h,o-z)
5213       include 'DIMENSIONS'
5214       include 'COMMON.GEO'
5215       include 'COMMON.LOCAL'
5216       include 'COMMON.IOUNITS'
5217       common /sccalc/ time11,time12,time112,theti,it,nlobit
5218       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5219       double precision contr(maxlob,-1:1)
5220       logical mixed
5221 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5222         escloc_i=0.0D0
5223         do j=1,3
5224           dersc(j)=0.0D0
5225           if (mixed) ddersc(j)=0.0d0
5226         enddo
5227         x3=x(3)
5228
5229 C Because of periodicity of the dependence of the SC energy in omega we have
5230 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5231 C To avoid underflows, first compute & store the exponents.
5232
5233         do iii=-1,1
5234
5235           x(3)=x3+iii*dwapi
5236
5237           do j=1,nlobit
5238             do k=1,3
5239               z(k)=x(k)-censc(k,j,it)
5240             enddo
5241             do k=1,3
5242               Axk=0.0D0
5243               do l=1,3
5244                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5245               enddo
5246               Ax(k,j,iii)=Axk
5247             enddo
5248             expfac=0.0D0
5249             do k=1,3
5250               expfac=expfac+Ax(k,j,iii)*z(k)
5251             enddo
5252             contr(j,iii)=expfac
5253           enddo ! j
5254
5255         enddo ! iii
5256
5257         x(3)=x3
5258 C As in the case of ebend, we want to avoid underflows in exponentiation and
5259 C subsequent NaNs and INFs in energy calculation.
5260 C Find the largest exponent
5261         emin=contr(1,-1)
5262         do iii=-1,1
5263           do j=1,nlobit
5264             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5265           enddo
5266         enddo
5267         emin=0.5D0*emin
5268 cd      print *,'it=',it,' emin=',emin
5269
5270 C Compute the contribution to SC energy and derivatives
5271         do iii=-1,1
5272
5273           do j=1,nlobit
5274 #ifdef OSF
5275             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5276             if(adexp.ne.adexp) adexp=1.0
5277             expfac=dexp(adexp)
5278 #else
5279             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5280 #endif
5281 cd          print *,'j=',j,' expfac=',expfac
5282             escloc_i=escloc_i+expfac
5283             do k=1,3
5284               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5285             enddo
5286             if (mixed) then
5287               do k=1,3,2
5288                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5289      &            +gaussc(k,2,j,it))*expfac
5290               enddo
5291             endif
5292           enddo
5293
5294         enddo ! iii
5295
5296         dersc(1)=dersc(1)/cos(theti)**2
5297         ddersc(1)=ddersc(1)/cos(theti)**2
5298         ddersc(3)=ddersc(3)
5299
5300         escloci=-(dlog(escloc_i)-emin)
5301         do j=1,3
5302           dersc(j)=dersc(j)/escloc_i
5303         enddo
5304         if (mixed) then
5305           do j=1,3,2
5306             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5307           enddo
5308         endif
5309       return
5310       end
5311 C------------------------------------------------------------------------------
5312       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5313       implicit real*8 (a-h,o-z)
5314       include 'DIMENSIONS'
5315       include 'COMMON.GEO'
5316       include 'COMMON.LOCAL'
5317       include 'COMMON.IOUNITS'
5318       common /sccalc/ time11,time12,time112,theti,it,nlobit
5319       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5320       double precision contr(maxlob)
5321       logical mixed
5322
5323       escloc_i=0.0D0
5324
5325       do j=1,3
5326         dersc(j)=0.0D0
5327       enddo
5328
5329       do j=1,nlobit
5330         do k=1,2
5331           z(k)=x(k)-censc(k,j,it)
5332         enddo
5333         z(3)=dwapi
5334         do k=1,3
5335           Axk=0.0D0
5336           do l=1,3
5337             Axk=Axk+gaussc(l,k,j,it)*z(l)
5338           enddo
5339           Ax(k,j)=Axk
5340         enddo
5341         expfac=0.0D0
5342         do k=1,3
5343           expfac=expfac+Ax(k,j)*z(k)
5344         enddo
5345         contr(j)=expfac
5346       enddo ! j
5347
5348 C As in the case of ebend, we want to avoid underflows in exponentiation and
5349 C subsequent NaNs and INFs in energy calculation.
5350 C Find the largest exponent
5351       emin=contr(1)
5352       do j=1,nlobit
5353         if (emin.gt.contr(j)) emin=contr(j)
5354       enddo
5355       emin=0.5D0*emin
5356
5357 C Compute the contribution to SC energy and derivatives
5358
5359       dersc12=0.0d0
5360       do j=1,nlobit
5361         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5362         escloc_i=escloc_i+expfac
5363         do k=1,2
5364           dersc(k)=dersc(k)+Ax(k,j)*expfac
5365         enddo
5366         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5367      &            +gaussc(1,2,j,it))*expfac
5368         dersc(3)=0.0d0
5369       enddo
5370
5371       dersc(1)=dersc(1)/cos(theti)**2
5372       dersc12=dersc12/cos(theti)**2
5373       escloci=-(dlog(escloc_i)-emin)
5374       do j=1,2
5375         dersc(j)=dersc(j)/escloc_i
5376       enddo
5377       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5378       return
5379       end
5380 #else
5381 c----------------------------------------------------------------------------------
5382       subroutine esc(escloc)
5383 C Calculate the local energy of a side chain and its derivatives in the
5384 C corresponding virtual-bond valence angles THETA and the spherical angles
5385 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5386 C added by Urszula Kozlowska. 07/11/2007
5387 C
5388       implicit real*8 (a-h,o-z)
5389       include 'DIMENSIONS'
5390       include 'COMMON.GEO'
5391       include 'COMMON.LOCAL'
5392       include 'COMMON.VAR'
5393       include 'COMMON.SCROT'
5394       include 'COMMON.INTERACT'
5395       include 'COMMON.DERIV'
5396       include 'COMMON.CHAIN'
5397       include 'COMMON.IOUNITS'
5398       include 'COMMON.NAMES'
5399       include 'COMMON.FFIELD'
5400       include 'COMMON.CONTROL'
5401       include 'COMMON.VECTORS'
5402       double precision x_prime(3),y_prime(3),z_prime(3)
5403      &    , sumene,dsc_i,dp2_i,x(65),
5404      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5405      &    de_dxx,de_dyy,de_dzz,de_dt
5406       double precision s1_t,s1_6_t,s2_t,s2_6_t
5407       double precision
5408      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5409      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5410      & dt_dCi(3),dt_dCi1(3)
5411       common /sccalc/ time11,time12,time112,theti,it,nlobit
5412       delta=0.02d0*pi
5413       escloc=0.0D0
5414 c      write(iout,*) "ESC: loc_start",loc_start," loc_end",loc_end
5415       do i=loc_start,loc_end
5416         costtab(i+1) =dcos(theta(i+1))
5417         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5418         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5419         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5420         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5421         cosfac=dsqrt(cosfac2)
5422         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5423         sinfac=dsqrt(sinfac2)
5424         it=itype(i)
5425         if (it.eq.10) goto 1
5426 c
5427 C  Compute the axes of tghe local cartesian coordinates system; store in
5428 c   x_prime, y_prime and z_prime
5429 c
5430         do j=1,3
5431           x_prime(j) = 0.00
5432           y_prime(j) = 0.00
5433           z_prime(j) = 0.00
5434         enddo
5435 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5436 C     &   dc_norm(3,i+nres)
5437         do j = 1,3
5438           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5439           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5440         enddo
5441         do j = 1,3
5442           z_prime(j) = -uz(j,i-1)
5443         enddo
5444 c       write (2,*) "i",i
5445 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5446 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5447 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5448 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5449 c      & " xy",scalar(x_prime(1),y_prime(1)),
5450 c      & " xz",scalar(x_prime(1),z_prime(1)),
5451 c      & " yy",scalar(y_prime(1),y_prime(1)),
5452 c      & " yz",scalar(y_prime(1),z_prime(1)),
5453 c      & " zz",scalar(z_prime(1),z_prime(1))
5454 c
5455 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5456 C to local coordinate system. Store in xx, yy, zz.
5457 c
5458         xx=0.0d0
5459         yy=0.0d0
5460         zz=0.0d0
5461         do j = 1,3
5462           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5463           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5464           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5465         enddo
5466
5467         xxtab(i)=xx
5468         yytab(i)=yy
5469         zztab(i)=zz
5470 C
5471 C Compute the energy of the ith side cbain
5472 C
5473 c        write (2,*) "xx",xx," yy",yy," zz",zz
5474         it=itype(i)
5475         do j = 1,65
5476           x(j) = sc_parmin(j,it)
5477         enddo
5478 #ifdef CHECK_COORD
5479 Cc diagnostics - remove later
5480         xx1 = dcos(alph(2))
5481         yy1 = dsin(alph(2))*dcos(omeg(2))
5482         zz1 = -dsin(alph(2))*dsin(omeg(2))
5483         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5484      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5485      &    xx1,yy1,zz1
5486 C,"  --- ", xx_w,yy_w,zz_w
5487 c end diagnostics
5488 #endif
5489         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5490      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5491      &   + x(10)*yy*zz
5492         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5493      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5494      & + x(20)*yy*zz
5495         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5496      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5497      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5498      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5499      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5500      &  +x(40)*xx*yy*zz
5501         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5502      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5503      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5504      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5505      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5506      &  +x(60)*xx*yy*zz
5507         dsc_i   = 0.743d0+x(61)
5508         dp2_i   = 1.9d0+x(62)
5509         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5510      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5511         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5512      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5513         s1=(1+x(63))/(0.1d0 + dscp1)
5514         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5515         s2=(1+x(65))/(0.1d0 + dscp2)
5516         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5517         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5518      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5519 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5520 c     &   sumene4,
5521 c     &   dscp1,dscp2,sumene
5522 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5523         escloc = escloc + sumene
5524         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5525      &     'escloc',i,sumene
5526 #ifdef DEBUG
5527 C
5528 C This section to check the numerical derivatives of the energy of ith side
5529 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5530 C #define DEBUG in the code to turn it on.
5531 C
5532         write (2,*) "sumene               =",sumene
5533         aincr=1.0d-7
5534         xxsave=xx
5535         xx=xx+aincr
5536         write (2,*) xx,yy,zz
5537         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5538         de_dxx_num=(sumenep-sumene)/aincr
5539         xx=xxsave
5540         write (2,*) "xx+ sumene from enesc=",sumenep
5541         yysave=yy
5542         yy=yy+aincr
5543         write (2,*) xx,yy,zz
5544         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5545         de_dyy_num=(sumenep-sumene)/aincr
5546         yy=yysave
5547         write (2,*) "yy+ sumene from enesc=",sumenep
5548         zzsave=zz
5549         zz=zz+aincr
5550         write (2,*) xx,yy,zz
5551         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5552         de_dzz_num=(sumenep-sumene)/aincr
5553         zz=zzsave
5554         write (2,*) "zz+ sumene from enesc=",sumenep
5555         costsave=cost2tab(i+1)
5556         sintsave=sint2tab(i+1)
5557         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5558         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5559         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5560         de_dt_num=(sumenep-sumene)/aincr
5561         write (2,*) " t+ sumene from enesc=",sumenep
5562         cost2tab(i+1)=costsave
5563         sint2tab(i+1)=sintsave
5564 C End of diagnostics section.
5565 #endif
5566 C
5567 C Compute the gradient of esc
5568 C
5569         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5570         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5571         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5572         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5573         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5574         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5575         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5576         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5577         pom1=(sumene3*sint2tab(i+1)+sumene1)
5578      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5579         pom2=(sumene4*cost2tab(i+1)+sumene2)
5580      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5581         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5582         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5583      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5584      &  +x(40)*yy*zz
5585         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5586         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5587      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5588      &  +x(60)*yy*zz
5589         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5590      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5591      &        +(pom1+pom2)*pom_dx
5592 #ifdef DEBUG
5593         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5594 #endif
5595 C
5596         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5597         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5598      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5599      &  +x(40)*xx*zz
5600         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5601         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5602      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5603      &  +x(59)*zz**2 +x(60)*xx*zz
5604         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5605      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5606      &        +(pom1-pom2)*pom_dy
5607 #ifdef DEBUG
5608         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5609 #endif
5610 C
5611         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5612      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5613      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5614      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5615      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5616      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5617      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5618      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5619 #ifdef DEBUG
5620         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5621 #endif
5622 C
5623         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5624      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5625      &  +pom1*pom_dt1+pom2*pom_dt2
5626 #ifdef DEBUG
5627         write(2,*), "de_dt = ", de_dt,de_dt_num
5628 #endif
5629 c
5630 C
5631        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5632        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5633        cosfac2xx=cosfac2*xx
5634        sinfac2yy=sinfac2*yy
5635        do k = 1,3
5636          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5637      &      vbld_inv(i+1)
5638          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5639      &      vbld_inv(i)
5640          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5641          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5642 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5643 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5644 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5645 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5646          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5647          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5648          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5649          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5650          dZZ_Ci1(k)=0.0d0
5651          dZZ_Ci(k)=0.0d0
5652          do j=1,3
5653            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5654            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5655          enddo
5656
5657          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5658          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5659          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5660 c
5661          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5662          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5663        enddo
5664
5665        do k=1,3
5666          dXX_Ctab(k,i)=dXX_Ci(k)
5667          dXX_C1tab(k,i)=dXX_Ci1(k)
5668          dYY_Ctab(k,i)=dYY_Ci(k)
5669          dYY_C1tab(k,i)=dYY_Ci1(k)
5670          dZZ_Ctab(k,i)=dZZ_Ci(k)
5671          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5672          dXX_XYZtab(k,i)=dXX_XYZ(k)
5673          dYY_XYZtab(k,i)=dYY_XYZ(k)
5674          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5675        enddo
5676
5677        do k = 1,3
5678 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5679 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5680 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5681 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5682 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5683 c     &    dt_dci(k)
5684 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5685 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5686          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5687      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5688          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5689      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5690          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5691      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5692        enddo
5693 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5694 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5695
5696 C to check gradient call subroutine check_grad
5697
5698     1 continue
5699       enddo
5700       return
5701       end
5702 c------------------------------------------------------------------------------
5703       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5704       implicit none
5705       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5706      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5707       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5708      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5709      &   + x(10)*yy*zz
5710       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5711      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5712      & + x(20)*yy*zz
5713       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5714      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5715      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5716      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5717      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5718      &  +x(40)*xx*yy*zz
5719       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5720      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5721      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5722      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5723      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5724      &  +x(60)*xx*yy*zz
5725       dsc_i   = 0.743d0+x(61)
5726       dp2_i   = 1.9d0+x(62)
5727       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5728      &          *(xx*cost2+yy*sint2))
5729       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5730      &          *(xx*cost2-yy*sint2))
5731       s1=(1+x(63))/(0.1d0 + dscp1)
5732       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5733       s2=(1+x(65))/(0.1d0 + dscp2)
5734       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5735       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5736      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5737       enesc=sumene
5738       return
5739       end
5740 #endif
5741 c------------------------------------------------------------------------------
5742       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5743 C
5744 C This procedure calculates two-body contact function g(rij) and its derivative:
5745 C
5746 C           eps0ij                                     !       x < -1
5747 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5748 C            0                                         !       x > 1
5749 C
5750 C where x=(rij-r0ij)/delta
5751 C
5752 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5753 C
5754       implicit none
5755       double precision rij,r0ij,eps0ij,fcont,fprimcont
5756       double precision x,x2,x4,delta
5757 c     delta=0.02D0*r0ij
5758 c      delta=0.2D0*r0ij
5759       x=(rij-r0ij)/delta
5760       if (x.lt.-1.0D0) then
5761         fcont=eps0ij
5762         fprimcont=0.0D0
5763       else if (x.le.1.0D0) then
5764         x2=x*x
5765         x4=x2*x2
5766         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5767         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5768       else
5769         fcont=0.0D0
5770         fprimcont=0.0D0
5771       endif
5772       return
5773       end
5774 c------------------------------------------------------------------------------
5775       subroutine splinthet(theti,delta,ss,ssder)
5776       implicit real*8 (a-h,o-z)
5777       include 'DIMENSIONS'
5778       include 'COMMON.VAR'
5779       include 'COMMON.GEO'
5780       thetup=pi-delta
5781       thetlow=delta
5782       if (theti.gt.pipol) then
5783         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5784       else
5785         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5786         ssder=-ssder
5787       endif
5788       return
5789       end
5790 c------------------------------------------------------------------------------
5791       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5792       implicit none
5793       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5794       double precision ksi,ksi2,ksi3,a1,a2,a3
5795       a1=fprim0*delta/(f1-f0)
5796       a2=3.0d0-2.0d0*a1
5797       a3=a1-2.0d0
5798       ksi=(x-x0)/delta
5799       ksi2=ksi*ksi
5800       ksi3=ksi2*ksi
5801       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5802       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5803       return
5804       end
5805 c------------------------------------------------------------------------------
5806       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5807       implicit none
5808       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5809       double precision ksi,ksi2,ksi3,a1,a2,a3
5810       ksi=(x-x0)/delta
5811       ksi2=ksi*ksi
5812       ksi3=ksi2*ksi
5813       a1=fprim0x*delta
5814       a2=3*(f1x-f0x)-2*fprim0x*delta
5815       a3=fprim0x*delta-2*(f1x-f0x)
5816       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5817       return
5818       end
5819 C-----------------------------------------------------------------------------
5820 #ifdef CRYST_TOR
5821 C-----------------------------------------------------------------------------
5822       subroutine etor(etors,edihcnstr)
5823       implicit real*8 (a-h,o-z)
5824       include 'DIMENSIONS'
5825       include 'COMMON.VAR'
5826       include 'COMMON.GEO'
5827       include 'COMMON.LOCAL'
5828       include 'COMMON.TORSION'
5829       include 'COMMON.INTERACT'
5830       include 'COMMON.DERIV'
5831       include 'COMMON.CHAIN'
5832       include 'COMMON.NAMES'
5833       include 'COMMON.IOUNITS'
5834       include 'COMMON.FFIELD'
5835       include 'COMMON.TORCNSTR'
5836       include 'COMMON.CONTROL'
5837       logical lprn
5838 C Set lprn=.true. for debugging
5839       lprn=.false.
5840 c      lprn=.true.
5841       etors=0.0D0
5842       do i=iphi_start,iphi_end
5843       etors_ii=0.0D0
5844         itori=itortyp(itype(i-2))
5845         itori1=itortyp(itype(i-1))
5846         phii=phi(i)
5847         gloci=0.0D0
5848 C Proline-Proline pair is a special case...
5849         if (itori.eq.3 .and. itori1.eq.3) then
5850           if (phii.gt.-dwapi3) then
5851             cosphi=dcos(3*phii)
5852             fac=1.0D0/(1.0D0-cosphi)
5853             etorsi=v1(1,3,3)*fac
5854             etorsi=etorsi+etorsi
5855             etors=etors+etorsi-v1(1,3,3)
5856             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5857             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5858           endif
5859           do j=1,3
5860             v1ij=v1(j+1,itori,itori1)
5861             v2ij=v2(j+1,itori,itori1)
5862             cosphi=dcos(j*phii)
5863             sinphi=dsin(j*phii)
5864             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5865             if (energy_dec) etors_ii=etors_ii+
5866      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5867             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5868           enddo
5869         else
5870           do j=1,nterm_old
5871             v1ij=v1(j,itori,itori1)
5872             v2ij=v2(j,itori,itori1)
5873             cosphi=dcos(j*phii)
5874             sinphi=dsin(j*phii)
5875             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5876             if (energy_dec) etors_ii=etors_ii+
5877      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5878             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5879           enddo
5880         endif
5881         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5882      &        'etor',i,etors_ii
5883         if (lprn)
5884      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5885      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5886      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5887         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5888         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5889       enddo
5890 ! 6/20/98 - dihedral angle constraints
5891       edihcnstr=0.0d0
5892       do i=1,ndih_constr
5893         itori=idih_constr(i)
5894         phii=phi(itori)
5895         difi=phii-phi0(i)
5896         if (difi.gt.drange(i)) then
5897           difi=difi-drange(i)
5898           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5899           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5900         else if (difi.lt.-drange(i)) then
5901           difi=difi+drange(i)
5902           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5903           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5904         endif
5905 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5906 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5907       enddo
5908 !      write (iout,*) 'edihcnstr',edihcnstr
5909       return
5910       end
5911 c------------------------------------------------------------------------------
5912 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5913       subroutine e_modeller(ehomology_constr)
5914       ehomology_constr=0.0d0
5915       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5916       return
5917       end
5918 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5919
5920 c------------------------------------------------------------------------------
5921       subroutine etor_d(etors_d)
5922       etors_d=0.0d0
5923       return
5924       end
5925 c----------------------------------------------------------------------------
5926 #else
5927       subroutine etor(etors,edihcnstr)
5928       implicit real*8 (a-h,o-z)
5929       include 'DIMENSIONS'
5930       include 'COMMON.VAR'
5931       include 'COMMON.GEO'
5932       include 'COMMON.LOCAL'
5933       include 'COMMON.TORSION'
5934       include 'COMMON.INTERACT'
5935       include 'COMMON.DERIV'
5936       include 'COMMON.CHAIN'
5937       include 'COMMON.NAMES'
5938       include 'COMMON.IOUNITS'
5939       include 'COMMON.FFIELD'
5940       include 'COMMON.TORCNSTR'
5941       include 'COMMON.CONTROL'
5942       logical lprn
5943 C Set lprn=.true. for debugging
5944       lprn=.false.
5945 c     lprn=.true.
5946       etors=0.0D0
5947       do i=iphi_start,iphi_end
5948       etors_ii=0.0D0
5949         itori=itortyp(itype(i-2))
5950         itori1=itortyp(itype(i-1))
5951         phii=phi(i)
5952         gloci=0.0D0
5953 C Regular cosine and sine terms
5954         do j=1,nterm(itori,itori1)
5955           v1ij=v1(j,itori,itori1)
5956           v2ij=v2(j,itori,itori1)
5957           cosphi=dcos(j*phii)
5958           sinphi=dsin(j*phii)
5959           etors=etors+v1ij*cosphi+v2ij*sinphi
5960           if (energy_dec) etors_ii=etors_ii+
5961      &                v1ij*cosphi+v2ij*sinphi
5962           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5963         enddo
5964 C Lorentz terms
5965 C                         v1
5966 C  E = SUM ----------------------------------- - v1
5967 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5968 C
5969         cosphi=dcos(0.5d0*phii)
5970         sinphi=dsin(0.5d0*phii)
5971         do j=1,nlor(itori,itori1)
5972           vl1ij=vlor1(j,itori,itori1)
5973           vl2ij=vlor2(j,itori,itori1)
5974           vl3ij=vlor3(j,itori,itori1)
5975           pom=vl2ij*cosphi+vl3ij*sinphi
5976           pom1=1.0d0/(pom*pom+1.0d0)
5977           etors=etors+vl1ij*pom1
5978           if (energy_dec) etors_ii=etors_ii+
5979      &                vl1ij*pom1
5980           pom=-pom*pom1*pom1
5981           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5982         enddo
5983 C Subtract the constant term
5984         etors=etors-v0(itori,itori1)
5985           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5986      &         'etor',i,etors_ii-v0(itori,itori1)
5987         if (lprn)
5988      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5989      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5990      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5991         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5992 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5993       enddo
5994 ! 6/20/98 - dihedral angle constraints
5995       edihcnstr=0.0d0
5996 c      do i=1,ndih_constr
5997       do i=idihconstr_start,idihconstr_end
5998         itori=idih_constr(i)
5999         phii=phi(itori)
6000         difi=pinorm(phii-phi0(i))
6001         if (difi.gt.drange(i)) then
6002           difi=difi-drange(i)
6003           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6004           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6005         else if (difi.lt.-drange(i)) then
6006           difi=difi+drange(i)
6007           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6008           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6009         else
6010           difi=0.0
6011         endif
6012 c        write (iout,*) "gloci", gloc(i-3,icg)
6013 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6014 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
6015 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6016       enddo
6017 cd       write (iout,*) 'edihcnstr',edihcnstr
6018       return
6019       end
6020 c----------------------------------------------------------------------------
6021 c MODELLER restraint function
6022       subroutine e_modeller(ehomology_constr)
6023       implicit real*8 (a-h,o-z)
6024       include 'DIMENSIONS'
6025
6026       integer nnn, i, j, k, ki, irec, l
6027       integer katy, odleglosci, test7
6028       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
6029       real*8 Eval,Erot
6030       real*8 distance(max_template),distancek(max_template),
6031      &    min_odl,godl(max_template),dih_diff(max_template)
6032
6033 c
6034 c     FP - 30/10/2014 Temporary specifications for homology restraints
6035 c
6036       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
6037      &                 sgtheta
6038       double precision, dimension (maxres) :: guscdiff,usc_diff
6039       double precision, dimension (max_template) ::
6040      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
6041      &           theta_diff
6042 c
6043
6044       include 'COMMON.SBRIDGE'
6045       include 'COMMON.CHAIN'
6046       include 'COMMON.GEO'
6047       include 'COMMON.DERIV'
6048       include 'COMMON.LOCAL'
6049       include 'COMMON.INTERACT'
6050       include 'COMMON.VAR'
6051       include 'COMMON.IOUNITS'
6052       include 'COMMON.MD'
6053       include 'COMMON.CONTROL'
6054 c
6055 c     From subroutine Econstr_back
6056 c
6057       include 'COMMON.NAMES'
6058       include 'COMMON.TIME1'
6059 c
6060
6061
6062       do i=1,max_template
6063         distancek(i)=9999999.9
6064       enddo
6065
6066
6067       odleg=0.0d0
6068
6069 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6070 c function)
6071 C AL 5/2/14 - Introduce list of restraints
6072 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6073 #ifdef DEBUG
6074       write(iout,*) "------- dist restrs start -------"
6075 #endif
6076       do ii = link_start_homo,link_end_homo
6077          i = ires_homo(ii)
6078          j = jres_homo(ii)
6079          dij=dist(i,j)
6080 c        write (iout,*) "dij(",i,j,") =",dij
6081          nexl=0
6082          do k=1,constr_homology
6083 c           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
6084            if(.not.l_homo(k,ii)) then
6085              nexl=nexl+1
6086              cycle
6087            endif
6088            distance(k)=odl(k,ii)-dij
6089 c          write (iout,*) "distance(",k,") =",distance(k)
6090 c
6091 c          For Gaussian-type Urestr
6092 c
6093            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6094 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6095 c          write (iout,*) "distancek(",k,") =",distancek(k)
6096 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6097 c
6098 c          For Lorentzian-type Urestr
6099 c
6100            if (waga_dist.lt.0.0d0) then
6101               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
6102               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
6103      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
6104            endif
6105          enddo
6106 c         write (iout,*) "distance: ii",ii," nexl",nexl
6107
6108
6109 c         min_odl=minval(distancek)
6110          do kk=1,constr_homology
6111           if(l_homo(kk,ii)) then
6112             min_odl=distancek(kk)
6113             exit
6114           endif
6115          enddo
6116          do kk=1,constr_homology
6117           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
6118      &              min_odl=distancek(kk)
6119          enddo
6120 c        write (iout,* )"min_odl",min_odl
6121 #ifdef DEBUG
6122          write (iout,*) "ij dij",i,j,dij
6123          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6124          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6125          write (iout,* )"min_odl",min_odl
6126 #endif
6127 #ifdef OLDRESTR
6128          odleg2=0.0d0
6129 #else
6130          if (waga_dist.ge.0.0d0) then
6131            odleg2=nexl
6132          else
6133            odleg2=0.0d0
6134          endif
6135 #endif
6136          do k=1,constr_homology
6137 c Nie wiem po co to liczycie jeszcze raz!
6138 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6139 c     &              (2*(sigma_odl(i,j,k))**2))
6140            if(.not.l_homo(k,ii)) cycle
6141            if (waga_dist.ge.0.0d0) then
6142 c
6143 c          For Gaussian-type Urestr
6144 c
6145             godl(k)=dexp(-distancek(k)+min_odl)
6146             odleg2=odleg2+godl(k)
6147 c
6148 c          For Lorentzian-type Urestr
6149 c
6150            else
6151             odleg2=odleg2+distancek(k)
6152            endif
6153
6154 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6155 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6156 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6157 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6158
6159          enddo
6160 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6161 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6162 #ifdef DEBUG
6163          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6164          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6165 #endif
6166            if (waga_dist.ge.0.0d0) then
6167 c
6168 c          For Gaussian-type Urestr
6169 c
6170               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6171 c
6172 c          For Lorentzian-type Urestr
6173 c
6174            else
6175               odleg=odleg+odleg2/constr_homology
6176            endif
6177 c
6178 c        write (iout,*) "odleg",odleg ! sum of -ln-s
6179 c Gradient
6180 c
6181 c          For Gaussian-type Urestr
6182 c
6183          if (waga_dist.ge.0.0d0) sum_godl=odleg2
6184          sum_sgodl=0.0d0
6185          do k=1,constr_homology
6186 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6187 c     &           *waga_dist)+min_odl
6188 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6189 c
6190          if(.not.l_homo(k,ii)) cycle
6191          if (waga_dist.ge.0.0d0) then
6192 c          For Gaussian-type Urestr
6193 c
6194            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6195 c
6196 c          For Lorentzian-type Urestr
6197 c
6198          else
6199            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
6200      &           sigma_odlir(k,ii)**2)**2)
6201          endif
6202            sum_sgodl=sum_sgodl+sgodl
6203
6204 c            sgodl2=sgodl2+sgodl
6205 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6206 c      write(iout,*) "constr_homology=",constr_homology
6207 c      write(iout,*) i, j, k, "TEST K"
6208          enddo
6209          if (waga_dist.ge.0.0d0) then
6210 c
6211 c          For Gaussian-type Urestr
6212 c
6213             grad_odl3=waga_homology(iset)*waga_dist
6214      &                *sum_sgodl/(sum_godl*dij)
6215 c
6216 c          For Lorentzian-type Urestr
6217 c
6218          else
6219 c Original grad expr modified by analogy w Gaussian-type Urestr grad
6220 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
6221             grad_odl3=-waga_homology(iset)*waga_dist*
6222      &                sum_sgodl/(constr_homology*dij)
6223          endif
6224 c
6225 c        grad_odl3=sum_sgodl/(sum_godl*dij)
6226
6227
6228 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6229 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6230 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6231
6232 ccc      write(iout,*) godl, sgodl, grad_odl3
6233
6234 c          grad_odl=grad_odl+grad_odl3
6235
6236          do jik=1,3
6237             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
6238 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6239 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6240 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6241             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
6242             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
6243 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6244 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6245 c         if (i.eq.25.and.j.eq.27) then
6246 c         write(iout,*) "jik",jik,"i",i,"j",j
6247 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
6248 c         write(iout,*) "grad_odl3",grad_odl3
6249 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
6250 c         write(iout,*) "ggodl",ggodl
6251 c         write(iout,*) "ghpbc(",jik,i,")",
6252 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
6253 c     &                 ghpbc(jik,j)
6254 c         endif
6255          enddo
6256 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
6257 ccc     & dLOG(odleg2),"-odleg=", -odleg
6258
6259       enddo ! ii-loop for dist
6260 #ifdef DEBUG
6261       write(iout,*) "------- dist restrs end -------"
6262 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
6263 c    &     waga_d.eq.1.0d0) call sum_gradient
6264 #endif
6265 c Pseudo-energy and gradient from dihedral-angle restraints from
6266 c homology templates
6267 c      write (iout,*) "End of distance loop"
6268 c      call flush(iout)
6269       kat=0.0d0
6270 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6271 #ifdef DEBUG
6272       write(iout,*) "------- dih restrs start -------"
6273       do i=idihconstr_start_homo,idihconstr_end_homo
6274         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
6275       enddo
6276 #endif
6277       do i=idihconstr_start_homo,idihconstr_end_homo
6278 c        betai=beta(i,i+1,i+2,i+3)
6279         betai = phi(i)
6280 c       write (iout,*) "betai =",betai
6281         kat2=0.0d0
6282         do k=1,constr_homology
6283           dih_diff(k)=pinorm(dih(k,i)-betai)
6284 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
6285 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6286 c     &                                   -(6.28318-dih_diff(i,k))
6287 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6288 c     &                                   6.28318+dih_diff(i,k)
6289 #ifdef OLD_DIHED
6290           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
6291 #else
6292           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
6293 #endif
6294 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
6295           gdih(k)=dexp(kat3)
6296           kat2=kat2+gdih(k)
6297 c          write(iout,*) "i",i," k",k," sigma",sigma_dih(k,i),
6298 c     &     " kat2=", kat2, "gdih=",gdih(k)
6299         enddo
6300 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
6301 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
6302 #ifdef DEBUG
6303         write (iout,*) "i",i," betai",betai," kat2",kat2
6304         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6305 #endif
6306         if (kat2.le.1.0d-14) cycle
6307         kat=kat-dLOG(kat2/constr_homology)
6308 c       write (iout,*) "kat",kat ! sum of -ln-s
6309
6310 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6311 ccc     & dLOG(kat2), "-kat=", -kat
6312
6313 c ----------------------------------------------------------------------
6314 c Gradient
6315 c ----------------------------------------------------------------------
6316
6317         sum_gdih=kat2
6318         sum_sgdih=0.0d0
6319         do k=1,constr_homology
6320 #ifdef OLD_DIHED
6321           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
6322 #else
6323           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
6324 #endif
6325 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
6326           sum_sgdih=sum_sgdih+sgdih
6327         enddo
6328 c       grad_dih3=sum_sgdih/sum_gdih
6329         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
6330
6331 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6332 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6333 ccc     & gloc(nphi+i-3,icg)
6334         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
6335 c        if (i.eq.25) then
6336 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
6337 c        endif
6338 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6339 ccc     & gloc(nphi+i-3,icg)
6340
6341       enddo ! i-loop for dih
6342 #ifdef DEBUG
6343       write(iout,*) "------- dih restrs end -------"
6344 #endif
6345
6346 c Pseudo-energy and gradient for theta angle restraints from
6347 c homology templates
6348 c FP 01/15 - inserted from econstr_local_test.F, loop structure
6349 c adapted
6350
6351 c
6352 c     For constr_homology reference structures (FP)
6353 c
6354 c     Uconst_back_tot=0.0d0
6355       Eval=0.0d0
6356       Erot=0.0d0
6357 c     Econstr_back legacy
6358       do i=1,nres
6359 c     do i=ithet_start,ithet_end
6360        dutheta(i)=0.0d0
6361 c     enddo
6362 c     do i=loc_start,loc_end
6363         do j=1,3
6364           duscdiff(j,i)=0.0d0
6365           duscdiffx(j,i)=0.0d0
6366         enddo
6367       enddo
6368 c
6369 c     do iref=1,nref
6370 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
6371 c     write (iout,*) "waga_theta",waga_theta
6372       if (waga_theta.gt.0.0d0) then
6373 #ifdef DEBUG
6374       write (iout,*) "usampl",usampl
6375       write(iout,*) "------- theta restrs start -------"
6376 c     do i=ithet_start,ithet_end
6377 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
6378 c     enddo
6379 #endif
6380 c     write (iout,*) "maxres",maxres,"nres",nres
6381
6382       do i=ithet_start,ithet_end
6383 c
6384 c     do i=1,nfrag_back
6385 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
6386 c
6387 c Deviation of theta angles wrt constr_homology ref structures
6388 c
6389         utheta_i=0.0d0 ! argument of Gaussian for single k
6390         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6391 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
6392 c       over residues in a fragment
6393 c       write (iout,*) "theta(",i,")=",theta(i)
6394         do k=1,constr_homology
6395 c
6396 c         dtheta_i=theta(j)-thetaref(j,iref)
6397 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
6398           theta_diff(k)=thetatpl(k,i)-theta(i)
6399 c
6400           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
6401 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
6402           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
6403           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
6404 c          write (iout,*) "i",i," k",k," sigma_theta",sigma_theta(k,i),
6405 c     &     " gtheta",gtheta(k)
6406 c         Gradient for single Gaussian restraint in subr Econstr_back
6407 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
6408 c
6409         enddo
6410 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
6411 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
6412
6413 c
6414 c         Gradient for multiple Gaussian restraint
6415         sum_gtheta=gutheta_i
6416         sum_sgtheta=0.0d0
6417         do k=1,constr_homology
6418 c        New generalized expr for multiple Gaussian from Econstr_back
6419          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
6420 c
6421 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
6422           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
6423         enddo
6424 c       Final value of gradient using same var as in Econstr_back
6425         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)
6426      &      +sum_sgtheta/sum_gtheta*waga_theta
6427      &               *waga_homology(iset)
6428 c        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
6429 c     &               *waga_homology(iset)
6430 c       dutheta(i)=sum_sgtheta/sum_gtheta
6431 c
6432 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
6433         Eval=Eval-dLOG(gutheta_i/constr_homology)
6434 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
6435 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
6436 c       Uconst_back=Uconst_back+utheta(i)
6437       enddo ! (i-loop for theta)
6438 #ifdef DEBUG
6439       write(iout,*) "------- theta restrs end -------"
6440 #endif
6441       endif
6442 c
6443 c Deviation of local SC geometry
6444 c
6445 c Separation of two i-loops (instructed by AL - 11/3/2014)
6446 c
6447 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
6448 c     write (iout,*) "waga_d",waga_d
6449
6450 #ifdef DEBUG
6451       write(iout,*) "------- SC restrs start -------"
6452       write (iout,*) "Initial duscdiff,duscdiffx"
6453       do i=loc_start,loc_end
6454         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
6455      &                 (duscdiffx(jik,i),jik=1,3)
6456       enddo
6457 #endif
6458       do i=loc_start,loc_end
6459         usc_diff_i=0.0d0 ! argument of Gaussian for single k
6460         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6461 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
6462 c       write(iout,*) "xxtab, yytab, zztab"
6463 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
6464         do k=1,constr_homology
6465 c
6466           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6467 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
6468           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6469           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6470 c         write(iout,*) "dxx, dyy, dzz"
6471 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6472 c
6473           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
6474 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
6475 c         uscdiffk(k)=usc_diff(i)
6476           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
6477 c          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
6478 c     &       " guscdiff2",guscdiff2(k)
6479           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
6480 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
6481 c     &      xxref(j),yyref(j),zzref(j)
6482         enddo
6483 c
6484 c       Gradient
6485 c
6486 c       Generalized expression for multiple Gaussian acc to that for a single
6487 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
6488 c
6489 c       Original implementation
6490 c       sum_guscdiff=guscdiff(i)
6491 c
6492 c       sum_sguscdiff=0.0d0
6493 c       do k=1,constr_homology
6494 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
6495 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
6496 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
6497 c       enddo
6498 c
6499 c       Implementation of new expressions for gradient (Jan. 2015)
6500 c
6501 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
6502         do k=1,constr_homology
6503 c
6504 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
6505 c       before. Now the drivatives should be correct
6506 c
6507           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6508 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
6509           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6510           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6511 c
6512 c         New implementation
6513 c
6514           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
6515      &                 sigma_d(k,i) ! for the grad wrt r'
6516 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
6517 c
6518 c
6519 c        New implementation
6520          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
6521          do jik=1,3
6522             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
6523      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
6524      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
6525             duscdiff(jik,i)=duscdiff(jik,i)+
6526      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
6527      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
6528             duscdiffx(jik,i)=duscdiffx(jik,i)+
6529      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
6530      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
6531 c
6532 #ifdef DEBUG
6533              write(iout,*) "jik",jik,"i",i
6534              write(iout,*) "dxx, dyy, dzz"
6535              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6536              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
6537 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
6538 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
6539 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
6540 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
6541 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
6542 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
6543 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
6544 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
6545 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
6546 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
6547 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
6548 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
6549 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
6550 c            endif
6551 #endif
6552          enddo
6553         enddo
6554 c
6555 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
6556 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
6557 c
6558 c        write (iout,*) i," uscdiff",uscdiff(i)
6559 c
6560 c Put together deviations from local geometry
6561
6562 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
6563 c      &            wfrag_back(3,i,iset)*uscdiff(i)
6564         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
6565 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
6566 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
6567 c       Uconst_back=Uconst_back+usc_diff(i)
6568 c
6569 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
6570 c
6571 c     New implment: multiplied by sum_sguscdiff
6572 c
6573
6574       enddo ! (i-loop for dscdiff)
6575
6576 c      endif
6577
6578 #ifdef DEBUG
6579       write(iout,*) "------- SC restrs end -------"
6580         write (iout,*) "------ After SC loop in e_modeller ------"
6581         do i=loc_start,loc_end
6582          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
6583          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
6584         enddo
6585       if (waga_theta.eq.1.0d0) then
6586       write (iout,*) "in e_modeller after SC restr end: dutheta"
6587       do i=ithet_start,ithet_end
6588         write (iout,*) i,dutheta(i)
6589       enddo
6590       endif
6591       if (waga_d.eq.1.0d0) then
6592       write (iout,*) "e_modeller after SC loop: duscdiff/x"
6593       do i=1,nres
6594         write (iout,*) i,(duscdiff(j,i),j=1,3)
6595         write (iout,*) i,(duscdiffx(j,i),j=1,3)
6596       enddo
6597       endif
6598 #endif
6599
6600 c Total energy from homology restraints
6601 #ifdef DEBUG
6602       write (iout,*) "odleg",odleg," kat",kat
6603 #endif
6604 c
6605 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
6606 c
6607 c     ehomology_constr=odleg+kat
6608 c
6609 c     For Lorentzian-type Urestr
6610 c
6611
6612       if (waga_dist.ge.0.0d0) then
6613 c
6614 c          For Gaussian-type Urestr
6615 c
6616         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
6617      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6618 c     write (iout,*) "ehomology_constr=",ehomology_constr
6619       else
6620 c
6621 c          For Lorentzian-type Urestr
6622 c
6623         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
6624      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
6625 c     write (iout,*) "ehomology_constr=",ehomology_constr
6626       endif
6627 #ifdef DEBUG
6628       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
6629      & "Eval",waga_theta,eval,
6630      &   "Erot",waga_d,Erot
6631       write (iout,*) "ehomology_constr",ehomology_constr
6632 #endif
6633       return
6634 c
6635 c FP 01/15 end
6636 c
6637   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6638   747 format(a12,i4,i4,i4,f8.3,f8.3)
6639   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6640   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6641   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6642      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6643       end
6644
6645 c------------------------------------------------------------------------------
6646       subroutine etor_d(etors_d)
6647 C 6/23/01 Compute double torsional energy
6648       implicit real*8 (a-h,o-z)
6649       include 'DIMENSIONS'
6650       include 'COMMON.VAR'
6651       include 'COMMON.GEO'
6652       include 'COMMON.LOCAL'
6653       include 'COMMON.TORSION'
6654       include 'COMMON.INTERACT'
6655       include 'COMMON.DERIV'
6656       include 'COMMON.CHAIN'
6657       include 'COMMON.NAMES'
6658       include 'COMMON.IOUNITS'
6659       include 'COMMON.FFIELD'
6660       include 'COMMON.TORCNSTR'
6661       include 'COMMON.CONTROL'
6662       logical lprn
6663 C Set lprn=.true. for debugging
6664       lprn=.false.
6665 c     lprn=.true.
6666       etors_d=0.0D0
6667       do i=iphid_start,iphid_end
6668         etors_d_ii=0.0D0
6669         itori=itortyp(itype(i-2))
6670         itori1=itortyp(itype(i-1))
6671         itori2=itortyp(itype(i))
6672         phii=phi(i)
6673         phii1=phi(i+1)
6674         gloci1=0.0D0
6675         gloci2=0.0D0
6676         do j=1,ntermd_1(itori,itori1,itori2)
6677           v1cij=v1c(1,j,itori,itori1,itori2)
6678           v1sij=v1s(1,j,itori,itori1,itori2)
6679           v2cij=v1c(2,j,itori,itori1,itori2)
6680           v2sij=v1s(2,j,itori,itori1,itori2)
6681           cosphi1=dcos(j*phii)
6682           sinphi1=dsin(j*phii)
6683           cosphi2=dcos(j*phii1)
6684           sinphi2=dsin(j*phii1)
6685           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6686      &     v2cij*cosphi2+v2sij*sinphi2
6687           if (energy_dec) etors_d_ii=etors_d_ii+
6688      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6689           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6690           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6691         enddo
6692         do k=2,ntermd_2(itori,itori1,itori2)
6693           do l=1,k-1
6694             v1cdij = v2c(k,l,itori,itori1,itori2)
6695             v2cdij = v2c(l,k,itori,itori1,itori2)
6696             v1sdij = v2s(k,l,itori,itori1,itori2)
6697             v2sdij = v2s(l,k,itori,itori1,itori2)
6698             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6699             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6700             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6701             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6702             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6703      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6704             if (energy_dec) etors_d_ii=etors_d_ii+
6705      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6706      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6707             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6708      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6709             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6710      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6711           enddo
6712         enddo
6713         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6714      &        'etor_d',i,etors_d_ii
6715         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6716         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6717 c        write (iout,*) "gloci", gloc(i-3,icg)
6718       enddo
6719       return
6720       end
6721 #endif
6722 c------------------------------------------------------------------------------
6723       subroutine eback_sc_corr(esccor)
6724 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6725 c        conformational states; temporarily implemented as differences
6726 c        between UNRES torsional potentials (dependent on three types of
6727 c        residues) and the torsional potentials dependent on all 20 types
6728 c        of residues computed from AM1  energy surfaces of terminally-blocked
6729 c        amino-acid residues.
6730       implicit real*8 (a-h,o-z)
6731       include 'DIMENSIONS'
6732       include 'COMMON.VAR'
6733       include 'COMMON.GEO'
6734       include 'COMMON.LOCAL'
6735       include 'COMMON.TORSION'
6736       include 'COMMON.SCCOR'
6737       include 'COMMON.INTERACT'
6738       include 'COMMON.DERIV'
6739       include 'COMMON.CHAIN'
6740       include 'COMMON.NAMES'
6741       include 'COMMON.IOUNITS'
6742       include 'COMMON.FFIELD'
6743       include 'COMMON.CONTROL'
6744       logical lprn
6745 C Set lprn=.true. for debugging
6746       lprn=.false.
6747 c      lprn=.true.
6748 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6749       esccor=0.0D0
6750       do i=itau_start,itau_end
6751         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6752         isccori=isccortyp(itype(i-2))
6753         isccori1=isccortyp(itype(i-1))
6754         phii=phi(i)
6755 cccc  Added 9 May 2012
6756 cc Tauangle is torsional engle depending on the value of first digit
6757 c(see comment below)
6758 cc Omicron is flat angle depending on the value of first digit
6759 c(see comment below)
6760
6761
6762         do intertyp=1,3 !intertyp
6763          esccor_ii=0.0D0
6764 cc Added 09 May 2012 (Adasko)
6765 cc  Intertyp means interaction type of backbone mainchain correlation:
6766 c   1 = SC...Ca...Ca...Ca
6767 c   2 = Ca...Ca...Ca...SC
6768 c   3 = SC...Ca...Ca...SCi
6769         gloci=0.0D0
6770         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6771      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6772      &      (itype(i-1).eq.21)))
6773      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6774      &     .or.(itype(i-2).eq.21)))
6775      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6776      &      (itype(i-1).eq.21)))) cycle
6777         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6778         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6779      & cycle
6780         do j=1,nterm_sccor(isccori,isccori1)
6781           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6782           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6783           cosphi=dcos(j*tauangle(intertyp,i))
6784           sinphi=dsin(j*tauangle(intertyp,i))
6785           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6786           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6787           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6788         enddo
6789          if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
6790      &         'esccor',i,intertyp,esccor_ii
6791         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6792 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6793 c     &gloc_sc(intertyp,i-3,icg)
6794         if (lprn)
6795      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6796      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6797      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6798      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6799         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6800        enddo !intertyp
6801       enddo
6802 c        do i=1,nres
6803 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6804 c        enddo
6805       return
6806       end
6807 c----------------------------------------------------------------------------
6808       subroutine multibody(ecorr)
6809 C This subroutine calculates multi-body contributions to energy following
6810 C the idea of Skolnick et al. If side chains I and J make a contact and
6811 C at the same time side chains I+1 and J+1 make a contact, an extra
6812 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6813       implicit real*8 (a-h,o-z)
6814       include 'DIMENSIONS'
6815       include 'COMMON.IOUNITS'
6816       include 'COMMON.DERIV'
6817       include 'COMMON.INTERACT'
6818       include 'COMMON.CONTACTS'
6819       double precision gx(3),gx1(3)
6820       logical lprn
6821
6822 C Set lprn=.true. for debugging
6823       lprn=.false.
6824
6825       if (lprn) then
6826         write (iout,'(a)') 'Contact function values:'
6827         do i=nnt,nct-2
6828           write (iout,'(i2,20(1x,i2,f10.5))')
6829      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6830         enddo
6831       endif
6832       ecorr=0.0D0
6833       do i=nnt,nct
6834         do j=1,3
6835           gradcorr(j,i)=0.0D0
6836           gradxorr(j,i)=0.0D0
6837         enddo
6838       enddo
6839       do i=nnt,nct-2
6840
6841         DO ISHIFT = 3,4
6842
6843         i1=i+ishift
6844         num_conti=num_cont(i)
6845         num_conti1=num_cont(i1)
6846         do jj=1,num_conti
6847           j=jcont(jj,i)
6848           do kk=1,num_conti1
6849             j1=jcont(kk,i1)
6850             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6851 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6852 cd   &                   ' ishift=',ishift
6853 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6854 C The system gains extra energy.
6855               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6856             endif   ! j1==j+-ishift
6857           enddo     ! kk
6858         enddo       ! jj
6859
6860         ENDDO ! ISHIFT
6861
6862       enddo         ! i
6863       return
6864       end
6865 c------------------------------------------------------------------------------
6866       double precision function esccorr(i,j,k,l,jj,kk)
6867       implicit real*8 (a-h,o-z)
6868       include 'DIMENSIONS'
6869       include 'COMMON.IOUNITS'
6870       include 'COMMON.DERIV'
6871       include 'COMMON.INTERACT'
6872       include 'COMMON.CONTACTS'
6873       double precision gx(3),gx1(3)
6874       logical lprn
6875       lprn=.false.
6876       eij=facont(jj,i)
6877       ekl=facont(kk,k)
6878 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6879 C Calculate the multi-body contribution to energy.
6880 C Calculate multi-body contributions to the gradient.
6881 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6882 cd   & k,l,(gacont(m,kk,k),m=1,3)
6883       do m=1,3
6884         gx(m) =ekl*gacont(m,jj,i)
6885         gx1(m)=eij*gacont(m,kk,k)
6886         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6887         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6888         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6889         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6890       enddo
6891       do m=i,j-1
6892         do ll=1,3
6893           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6894         enddo
6895       enddo
6896       do m=k,l-1
6897         do ll=1,3
6898           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6899         enddo
6900       enddo
6901       esccorr=-eij*ekl
6902       return
6903       end
6904 c------------------------------------------------------------------------------
6905       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6906 C This subroutine calculates multi-body contributions to hydrogen-bonding
6907       implicit real*8 (a-h,o-z)
6908       include 'DIMENSIONS'
6909       include 'COMMON.IOUNITS'
6910 #ifdef MPI
6911       include "mpif.h"
6912       parameter (max_cont=maxconts)
6913       parameter (max_dim=26)
6914       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6915       double precision zapas(max_dim,maxconts,max_fg_procs),
6916      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6917       common /przechowalnia/ zapas
6918       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6919      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6920 #endif
6921       include 'COMMON.SETUP'
6922       include 'COMMON.FFIELD'
6923       include 'COMMON.DERIV'
6924       include 'COMMON.INTERACT'
6925       include 'COMMON.CONTACTS'
6926       include 'COMMON.CONTROL'
6927       include 'COMMON.LOCAL'
6928       double precision gx(3),gx1(3),time00
6929       logical lprn,ldone
6930
6931 C Set lprn=.true. for debugging
6932       lprn=.false.
6933 #ifdef MPI
6934       n_corr=0
6935       n_corr1=0
6936       if (nfgtasks.le.1) goto 30
6937       if (lprn) then
6938         write (iout,'(a)') 'Contact function values before RECEIVE:'
6939         do i=nnt,nct-2
6940           write (iout,'(2i3,50(1x,i2,f5.2))')
6941      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6942      &    j=1,num_cont_hb(i))
6943         enddo
6944       endif
6945       call flush(iout)
6946       do i=1,ntask_cont_from
6947         ncont_recv(i)=0
6948       enddo
6949       do i=1,ntask_cont_to
6950         ncont_sent(i)=0
6951       enddo
6952 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6953 c     & ntask_cont_to
6954 C Make the list of contacts to send to send to other procesors
6955 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6956 c      call flush(iout)
6957       do i=iturn3_start,iturn3_end
6958 c        write (iout,*) "make contact list turn3",i," num_cont",
6959 c     &    num_cont_hb(i)
6960         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6961       enddo
6962       do i=iturn4_start,iturn4_end
6963 c        write (iout,*) "make contact list turn4",i," num_cont",
6964 c     &   num_cont_hb(i)
6965         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6966       enddo
6967       do ii=1,nat_sent
6968         i=iat_sent(ii)
6969 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6970 c     &    num_cont_hb(i)
6971         do j=1,num_cont_hb(i)
6972         do k=1,4
6973           jjc=jcont_hb(j,i)
6974           iproc=iint_sent_local(k,jjc,ii)
6975 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6976           if (iproc.gt.0) then
6977             ncont_sent(iproc)=ncont_sent(iproc)+1
6978             nn=ncont_sent(iproc)
6979             zapas(1,nn,iproc)=i
6980             zapas(2,nn,iproc)=jjc
6981             zapas(3,nn,iproc)=facont_hb(j,i)
6982             zapas(4,nn,iproc)=ees0p(j,i)
6983             zapas(5,nn,iproc)=ees0m(j,i)
6984             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6985             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6986             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6987             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6988             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6989             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6990             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6991             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6992             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6993             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6994             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6995             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6996             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6997             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6998             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6999             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7000             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7001             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7002             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7003             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7004             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7005           endif
7006         enddo
7007         enddo
7008       enddo
7009       if (lprn) then
7010       write (iout,*)
7011      &  "Numbers of contacts to be sent to other processors",
7012      &  (ncont_sent(i),i=1,ntask_cont_to)
7013       write (iout,*) "Contacts sent"
7014       do ii=1,ntask_cont_to
7015         nn=ncont_sent(ii)
7016         iproc=itask_cont_to(ii)
7017         write (iout,*) nn," contacts to processor",iproc,
7018      &   " of CONT_TO_COMM group"
7019         do i=1,nn
7020           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7021         enddo
7022       enddo
7023       call flush(iout)
7024       endif
7025       CorrelType=477
7026       CorrelID=fg_rank+1
7027       CorrelType1=478
7028       CorrelID1=nfgtasks+fg_rank+1
7029       ireq=0
7030 C Receive the numbers of needed contacts from other processors
7031       do ii=1,ntask_cont_from
7032         iproc=itask_cont_from(ii)
7033         ireq=ireq+1
7034         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7035      &    FG_COMM,req(ireq),IERR)
7036       enddo
7037 c      write (iout,*) "IRECV ended"
7038 c      call flush(iout)
7039 C Send the number of contacts needed by other processors
7040       do ii=1,ntask_cont_to
7041         iproc=itask_cont_to(ii)
7042         ireq=ireq+1
7043         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7044      &    FG_COMM,req(ireq),IERR)
7045       enddo
7046 c      write (iout,*) "ISEND ended"
7047 c      write (iout,*) "number of requests (nn)",ireq
7048       call flush(iout)
7049       if (ireq.gt.0)
7050      &  call MPI_Waitall(ireq,req,status_array,ierr)
7051 c      write (iout,*)
7052 c     &  "Numbers of contacts to be received from other processors",
7053 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7054 c      call flush(iout)
7055 C Receive contacts
7056       ireq=0
7057       do ii=1,ntask_cont_from
7058         iproc=itask_cont_from(ii)
7059         nn=ncont_recv(ii)
7060 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7061 c     &   " of CONT_TO_COMM group"
7062         call flush(iout)
7063         if (nn.gt.0) then
7064           ireq=ireq+1
7065           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7066      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7067 c          write (iout,*) "ireq,req",ireq,req(ireq)
7068         endif
7069       enddo
7070 C Send the contacts to processors that need them
7071       do ii=1,ntask_cont_to
7072         iproc=itask_cont_to(ii)
7073         nn=ncont_sent(ii)
7074 c        write (iout,*) nn," contacts to processor",iproc,
7075 c     &   " of CONT_TO_COMM group"
7076         if (nn.gt.0) then
7077           ireq=ireq+1
7078           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7079      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7080 c          write (iout,*) "ireq,req",ireq,req(ireq)
7081 c          do i=1,nn
7082 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7083 c          enddo
7084         endif
7085       enddo
7086 c      write (iout,*) "number of requests (contacts)",ireq
7087 c      write (iout,*) "req",(req(i),i=1,4)
7088 c      call flush(iout)
7089       if (ireq.gt.0)
7090      & call MPI_Waitall(ireq,req,status_array,ierr)
7091       do iii=1,ntask_cont_from
7092         iproc=itask_cont_from(iii)
7093         nn=ncont_recv(iii)
7094         if (lprn) then
7095         write (iout,*) "Received",nn," contacts from processor",iproc,
7096      &   " of CONT_FROM_COMM group"
7097         call flush(iout)
7098         do i=1,nn
7099           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7100         enddo
7101         call flush(iout)
7102         endif
7103         do i=1,nn
7104           ii=zapas_recv(1,i,iii)
7105 c Flag the received contacts to prevent double-counting
7106           jj=-zapas_recv(2,i,iii)
7107 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7108 c          call flush(iout)
7109           nnn=num_cont_hb(ii)+1
7110           num_cont_hb(ii)=nnn
7111           jcont_hb(nnn,ii)=jj
7112           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7113           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7114           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7115           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7116           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7117           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7118           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7119           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7120           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7121           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7122           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7123           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7124           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7125           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7126           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7127           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7128           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7129           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7130           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7131           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7132           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7133           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7134           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7135           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7136         enddo
7137       enddo
7138       call flush(iout)
7139       if (lprn) then
7140         write (iout,'(a)') 'Contact function values after receive:'
7141         do i=nnt,nct-2
7142           write (iout,'(2i3,50(1x,i3,f5.2))')
7143      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7144      &    j=1,num_cont_hb(i))
7145         enddo
7146         call flush(iout)
7147       endif
7148    30 continue
7149 #endif
7150       if (lprn) then
7151         write (iout,'(a)') 'Contact function values:'
7152         do i=nnt,nct-2
7153           write (iout,'(2i3,50(1x,i3,f5.2))')
7154      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7155      &    j=1,num_cont_hb(i))
7156         enddo
7157       endif
7158       ecorr=0.0D0
7159 C Remove the loop below after debugging !!!
7160       do i=nnt,nct
7161         do j=1,3
7162           gradcorr(j,i)=0.0D0
7163           gradxorr(j,i)=0.0D0
7164         enddo
7165       enddo
7166 C Calculate the local-electrostatic correlation terms
7167       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7168         i1=i+1
7169         num_conti=num_cont_hb(i)
7170         num_conti1=num_cont_hb(i+1)
7171         do jj=1,num_conti
7172           j=jcont_hb(jj,i)
7173           jp=iabs(j)
7174           do kk=1,num_conti1
7175             j1=jcont_hb(kk,i1)
7176             jp1=iabs(j1)
7177 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7178 c     &         ' jj=',jj,' kk=',kk
7179             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7180      &          .or. j.lt.0 .and. j1.gt.0) .and.
7181      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7182 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7183 C The system gains extra energy.
7184               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7185               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
7186      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7187               n_corr=n_corr+1
7188             else if (j1.eq.j) then
7189 C Contacts I-J and I-(J+1) occur simultaneously.
7190 C The system loses extra energy.
7191 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7192             endif
7193           enddo ! kk
7194           do kk=1,num_conti
7195             j1=jcont_hb(kk,i)
7196 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7197 c    &         ' jj=',jj,' kk=',kk
7198             if (j1.eq.j+1) then
7199 C Contacts I-J and (I+1)-J occur simultaneously.
7200 C The system loses extra energy.
7201 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7202             endif ! j1==j+1
7203           enddo ! kk
7204         enddo ! jj
7205       enddo ! i
7206       return
7207       end
7208 c------------------------------------------------------------------------------
7209       subroutine add_hb_contact(ii,jj,itask)
7210       implicit real*8 (a-h,o-z)
7211       include "DIMENSIONS"
7212       include "COMMON.IOUNITS"
7213       integer max_cont
7214       integer max_dim
7215       parameter (max_cont=maxconts)
7216       parameter (max_dim=26)
7217       include "COMMON.CONTACTS"
7218       double precision zapas(max_dim,maxconts,max_fg_procs),
7219      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7220       common /przechowalnia/ zapas
7221       integer i,j,ii,jj,iproc,itask(4),nn
7222 c      write (iout,*) "itask",itask
7223       do i=1,2
7224         iproc=itask(i)
7225         if (iproc.gt.0) then
7226           do j=1,num_cont_hb(ii)
7227             jjc=jcont_hb(j,ii)
7228 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7229             if (jjc.eq.jj) then
7230               ncont_sent(iproc)=ncont_sent(iproc)+1
7231               nn=ncont_sent(iproc)
7232               zapas(1,nn,iproc)=ii
7233               zapas(2,nn,iproc)=jjc
7234               zapas(3,nn,iproc)=facont_hb(j,ii)
7235               zapas(4,nn,iproc)=ees0p(j,ii)
7236               zapas(5,nn,iproc)=ees0m(j,ii)
7237               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7238               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7239               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7240               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7241               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7242               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7243               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7244               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7245               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7246               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7247               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7248               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7249               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7250               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7251               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7252               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7253               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7254               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7255               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7256               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7257               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7258               exit
7259             endif
7260           enddo
7261         endif
7262       enddo
7263       return
7264       end
7265 c------------------------------------------------------------------------------
7266       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7267      &  n_corr1)
7268 C This subroutine calculates multi-body contributions to hydrogen-bonding
7269       implicit real*8 (a-h,o-z)
7270       include 'DIMENSIONS'
7271       include 'COMMON.IOUNITS'
7272 #ifdef MPI
7273       include "mpif.h"
7274       parameter (max_cont=maxconts)
7275       parameter (max_dim=70)
7276       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7277       double precision zapas(max_dim,maxconts,max_fg_procs),
7278      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7279       common /przechowalnia/ zapas
7280       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7281      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7282 #endif
7283       include 'COMMON.SETUP'
7284       include 'COMMON.FFIELD'
7285       include 'COMMON.DERIV'
7286       include 'COMMON.LOCAL'
7287       include 'COMMON.INTERACT'
7288       include 'COMMON.CONTACTS'
7289       include 'COMMON.CHAIN'
7290       include 'COMMON.CONTROL'
7291       double precision gx(3),gx1(3)
7292       integer num_cont_hb_old(maxres)
7293       logical lprn,ldone
7294       double precision eello4,eello5,eelo6,eello_turn6
7295       external eello4,eello5,eello6,eello_turn6
7296 C Set lprn=.true. for debugging
7297       lprn=.false.
7298       eturn6=0.0d0
7299 #ifdef MPI
7300       do i=1,nres
7301         num_cont_hb_old(i)=num_cont_hb(i)
7302       enddo
7303       n_corr=0
7304       n_corr1=0
7305       if (nfgtasks.le.1) goto 30
7306       if (lprn) then
7307         write (iout,'(a)') 'Contact function values before RECEIVE:'
7308         do i=nnt,nct-2
7309           write (iout,'(2i3,50(1x,i2,f5.2))')
7310      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7311      &    j=1,num_cont_hb(i))
7312         enddo
7313       endif
7314       call flush(iout)
7315       do i=1,ntask_cont_from
7316         ncont_recv(i)=0
7317       enddo
7318       do i=1,ntask_cont_to
7319         ncont_sent(i)=0
7320       enddo
7321 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7322 c     & ntask_cont_to
7323 C Make the list of contacts to send to send to other procesors
7324       do i=iturn3_start,iturn3_end
7325 c        write (iout,*) "make contact list turn3",i," num_cont",
7326 c     &    num_cont_hb(i)
7327         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7328       enddo
7329       do i=iturn4_start,iturn4_end
7330 c        write (iout,*) "make contact list turn4",i," num_cont",
7331 c     &   num_cont_hb(i)
7332         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7333       enddo
7334       do ii=1,nat_sent
7335         i=iat_sent(ii)
7336 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7337 c     &    num_cont_hb(i)
7338         do j=1,num_cont_hb(i)
7339         do k=1,4
7340           jjc=jcont_hb(j,i)
7341           iproc=iint_sent_local(k,jjc,ii)
7342 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7343           if (iproc.ne.0) then
7344             ncont_sent(iproc)=ncont_sent(iproc)+1
7345             nn=ncont_sent(iproc)
7346             zapas(1,nn,iproc)=i
7347             zapas(2,nn,iproc)=jjc
7348             zapas(3,nn,iproc)=d_cont(j,i)
7349             ind=3
7350             do kk=1,3
7351               ind=ind+1
7352               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7353             enddo
7354             do kk=1,2
7355               do ll=1,2
7356                 ind=ind+1
7357                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7358               enddo
7359             enddo
7360             do jj=1,5
7361               do kk=1,3
7362                 do ll=1,2
7363                   do mm=1,2
7364                     ind=ind+1
7365                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7366                   enddo
7367                 enddo
7368               enddo
7369             enddo
7370           endif
7371         enddo
7372         enddo
7373       enddo
7374       if (lprn) then
7375       write (iout,*)
7376      &  "Numbers of contacts to be sent to other processors",
7377      &  (ncont_sent(i),i=1,ntask_cont_to)
7378       write (iout,*) "Contacts sent"
7379       do ii=1,ntask_cont_to
7380         nn=ncont_sent(ii)
7381         iproc=itask_cont_to(ii)
7382         write (iout,*) nn," contacts to processor",iproc,
7383      &   " of CONT_TO_COMM group"
7384         do i=1,nn
7385           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7386         enddo
7387       enddo
7388       call flush(iout)
7389       endif
7390       CorrelType=477
7391       CorrelID=fg_rank+1
7392       CorrelType1=478
7393       CorrelID1=nfgtasks+fg_rank+1
7394       ireq=0
7395 C Receive the numbers of needed contacts from other processors
7396       do ii=1,ntask_cont_from
7397         iproc=itask_cont_from(ii)
7398         ireq=ireq+1
7399         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7400      &    FG_COMM,req(ireq),IERR)
7401       enddo
7402 c      write (iout,*) "IRECV ended"
7403 c      call flush(iout)
7404 C Send the number of contacts needed by other processors
7405       do ii=1,ntask_cont_to
7406         iproc=itask_cont_to(ii)
7407         ireq=ireq+1
7408         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7409      &    FG_COMM,req(ireq),IERR)
7410       enddo
7411 c      write (iout,*) "ISEND ended"
7412 c      write (iout,*) "number of requests (nn)",ireq
7413       call flush(iout)
7414       if (ireq.gt.0)
7415      &  call MPI_Waitall(ireq,req,status_array,ierr)
7416 c      write (iout,*)
7417 c     &  "Numbers of contacts to be received from other processors",
7418 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7419 c      call flush(iout)
7420 C Receive contacts
7421       ireq=0
7422       do ii=1,ntask_cont_from
7423         iproc=itask_cont_from(ii)
7424         nn=ncont_recv(ii)
7425 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7426 c     &   " of CONT_TO_COMM group"
7427         call flush(iout)
7428         if (nn.gt.0) then
7429           ireq=ireq+1
7430           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7431      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7432 c          write (iout,*) "ireq,req",ireq,req(ireq)
7433         endif
7434       enddo
7435 C Send the contacts to processors that need them
7436       do ii=1,ntask_cont_to
7437         iproc=itask_cont_to(ii)
7438         nn=ncont_sent(ii)
7439 c        write (iout,*) nn," contacts to processor",iproc,
7440 c     &   " of CONT_TO_COMM group"
7441         if (nn.gt.0) then
7442           ireq=ireq+1
7443           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7444      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7445 c          write (iout,*) "ireq,req",ireq,req(ireq)
7446 c          do i=1,nn
7447 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7448 c          enddo
7449         endif
7450       enddo
7451 c      write (iout,*) "number of requests (contacts)",ireq
7452 c      write (iout,*) "req",(req(i),i=1,4)
7453 c      call flush(iout)
7454       if (ireq.gt.0)
7455      & call MPI_Waitall(ireq,req,status_array,ierr)
7456       do iii=1,ntask_cont_from
7457         iproc=itask_cont_from(iii)
7458         nn=ncont_recv(iii)
7459         if (lprn) then
7460         write (iout,*) "Received",nn," contacts from processor",iproc,
7461      &   " of CONT_FROM_COMM group"
7462         call flush(iout)
7463         do i=1,nn
7464           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7465         enddo
7466         call flush(iout)
7467         endif
7468         do i=1,nn
7469           ii=zapas_recv(1,i,iii)
7470 c Flag the received contacts to prevent double-counting
7471           jj=-zapas_recv(2,i,iii)
7472 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7473 c          call flush(iout)
7474           nnn=num_cont_hb(ii)+1
7475           num_cont_hb(ii)=nnn
7476           jcont_hb(nnn,ii)=jj
7477           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7478           ind=3
7479           do kk=1,3
7480             ind=ind+1
7481             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7482           enddo
7483           do kk=1,2
7484             do ll=1,2
7485               ind=ind+1
7486               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7487             enddo
7488           enddo
7489           do jj=1,5
7490             do kk=1,3
7491               do ll=1,2
7492                 do mm=1,2
7493                   ind=ind+1
7494                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7495                 enddo
7496               enddo
7497             enddo
7498           enddo
7499         enddo
7500       enddo
7501       call flush(iout)
7502       if (lprn) then
7503         write (iout,'(a)') 'Contact function values after receive:'
7504         do i=nnt,nct-2
7505           write (iout,'(2i3,50(1x,i3,5f6.3))')
7506      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7507      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7508         enddo
7509         call flush(iout)
7510       endif
7511    30 continue
7512 #endif
7513       if (lprn) then
7514         write (iout,'(a)') 'Contact function values:'
7515         do i=nnt,nct-2
7516           write (iout,'(2i3,50(1x,i2,5f6.3))')
7517      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7518      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7519         enddo
7520       endif
7521       ecorr=0.0D0
7522       ecorr5=0.0d0
7523       ecorr6=0.0d0
7524 C Remove the loop below after debugging !!!
7525       do i=nnt,nct
7526         do j=1,3
7527           gradcorr(j,i)=0.0D0
7528           gradxorr(j,i)=0.0D0
7529         enddo
7530       enddo
7531 C Calculate the dipole-dipole interaction energies
7532       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7533       do i=iatel_s,iatel_e+1
7534         num_conti=num_cont_hb(i)
7535         do jj=1,num_conti
7536           j=jcont_hb(jj,i)
7537 #ifdef MOMENT
7538           call dipole(i,j,jj)
7539 #endif
7540         enddo
7541       enddo
7542       endif
7543 C Calculate the local-electrostatic correlation terms
7544 c                write (iout,*) "gradcorr5 in eello5 before loop"
7545 c                do iii=1,nres
7546 c                  write (iout,'(i5,3f10.5)')
7547 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7548 c                enddo
7549       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7550 c        write (iout,*) "corr loop i",i
7551         i1=i+1
7552         num_conti=num_cont_hb(i)
7553         num_conti1=num_cont_hb(i+1)
7554         do jj=1,num_conti
7555           j=jcont_hb(jj,i)
7556           jp=iabs(j)
7557           do kk=1,num_conti1
7558             j1=jcont_hb(kk,i1)
7559             jp1=iabs(j1)
7560 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7561 c     &         ' jj=',jj,' kk=',kk
7562 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7563             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7564      &          .or. j.lt.0 .and. j1.gt.0) .and.
7565      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7566 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7567 C The system gains extra energy.
7568               n_corr=n_corr+1
7569               sqd1=dsqrt(d_cont(jj,i))
7570               sqd2=dsqrt(d_cont(kk,i1))
7571               sred_geom = sqd1*sqd2
7572               IF (sred_geom.lt.cutoff_corr) THEN
7573                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7574      &            ekont,fprimcont)
7575 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7576 cd     &         ' jj=',jj,' kk=',kk
7577                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7578                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7579                 do l=1,3
7580                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7581                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7582                 enddo
7583                 n_corr1=n_corr1+1
7584 cd               write (iout,*) 'sred_geom=',sred_geom,
7585 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7586 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7587 cd               write (iout,*) "g_contij",g_contij
7588 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7589 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7590                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7591                 if (wcorr4.gt.0.0d0)
7592      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7593                   if (energy_dec.and.wcorr4.gt.0.0d0)
7594      1                 write (iout,'(a6,4i5,0pf7.3)')
7595      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7596 c                write (iout,*) "gradcorr5 before eello5"
7597 c                do iii=1,nres
7598 c                  write (iout,'(i5,3f10.5)')
7599 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7600 c                enddo
7601                 if (wcorr5.gt.0.0d0)
7602      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7603 c                write (iout,*) "gradcorr5 after eello5"
7604 c                do iii=1,nres
7605 c                  write (iout,'(i5,3f10.5)')
7606 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7607 c                enddo
7608                   if (energy_dec.and.wcorr5.gt.0.0d0)
7609      1                 write (iout,'(a6,4i5,0pf7.3)')
7610      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7611 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7612 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7613                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7614      &               .or. wturn6.eq.0.0d0))then
7615 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7616                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7617                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7618      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7619 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7620 cd     &            'ecorr6=',ecorr6
7621 cd                write (iout,'(4e15.5)') sred_geom,
7622 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7623 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7624 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7625                 else if (wturn6.gt.0.0d0
7626      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7627 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7628                   eturn6=eturn6+eello_turn6(i,jj,kk)
7629                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7630      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7631 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7632                 endif
7633               ENDIF
7634 1111          continue
7635             endif
7636           enddo ! kk
7637         enddo ! jj
7638       enddo ! i
7639       do i=1,nres
7640         num_cont_hb(i)=num_cont_hb_old(i)
7641       enddo
7642 c                write (iout,*) "gradcorr5 in eello5"
7643 c                do iii=1,nres
7644 c                  write (iout,'(i5,3f10.5)')
7645 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7646 c                enddo
7647       return
7648       end
7649 c------------------------------------------------------------------------------
7650       subroutine add_hb_contact_eello(ii,jj,itask)
7651       implicit real*8 (a-h,o-z)
7652       include "DIMENSIONS"
7653       include "COMMON.IOUNITS"
7654       integer max_cont
7655       integer max_dim
7656       parameter (max_cont=maxconts)
7657       parameter (max_dim=70)
7658       include "COMMON.CONTACTS"
7659       double precision zapas(max_dim,maxconts,max_fg_procs),
7660      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7661       common /przechowalnia/ zapas
7662       integer i,j,ii,jj,iproc,itask(4),nn
7663 c      write (iout,*) "itask",itask
7664       do i=1,2
7665         iproc=itask(i)
7666         if (iproc.gt.0) then
7667           do j=1,num_cont_hb(ii)
7668             jjc=jcont_hb(j,ii)
7669 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7670             if (jjc.eq.jj) then
7671               ncont_sent(iproc)=ncont_sent(iproc)+1
7672               nn=ncont_sent(iproc)
7673               zapas(1,nn,iproc)=ii
7674               zapas(2,nn,iproc)=jjc
7675               zapas(3,nn,iproc)=d_cont(j,ii)
7676               ind=3
7677               do kk=1,3
7678                 ind=ind+1
7679                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7680               enddo
7681               do kk=1,2
7682                 do ll=1,2
7683                   ind=ind+1
7684                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7685                 enddo
7686               enddo
7687               do jj=1,5
7688                 do kk=1,3
7689                   do ll=1,2
7690                     do mm=1,2
7691                       ind=ind+1
7692                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7693                     enddo
7694                   enddo
7695                 enddo
7696               enddo
7697               exit
7698             endif
7699           enddo
7700         endif
7701       enddo
7702       return
7703       end
7704 c------------------------------------------------------------------------------
7705       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7706       implicit real*8 (a-h,o-z)
7707       include 'DIMENSIONS'
7708       include 'COMMON.IOUNITS'
7709       include 'COMMON.DERIV'
7710       include 'COMMON.INTERACT'
7711       include 'COMMON.CONTACTS'
7712       double precision gx(3),gx1(3)
7713       logical lprn
7714       lprn=.false.
7715       eij=facont_hb(jj,i)
7716       ekl=facont_hb(kk,k)
7717       ees0pij=ees0p(jj,i)
7718       ees0pkl=ees0p(kk,k)
7719       ees0mij=ees0m(jj,i)
7720       ees0mkl=ees0m(kk,k)
7721       ekont=eij*ekl
7722       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7723 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7724 C Following 4 lines for diagnostics.
7725 cd    ees0pkl=0.0D0
7726 cd    ees0pij=1.0D0
7727 cd    ees0mkl=0.0D0
7728 cd    ees0mij=1.0D0
7729 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7730 c     & 'Contacts ',i,j,
7731 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7732 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7733 c     & 'gradcorr_long'
7734 C Calculate the multi-body contribution to energy.
7735 c      ecorr=ecorr+ekont*ees
7736 C Calculate multi-body contributions to the gradient.
7737       coeffpees0pij=coeffp*ees0pij
7738       coeffmees0mij=coeffm*ees0mij
7739       coeffpees0pkl=coeffp*ees0pkl
7740       coeffmees0mkl=coeffm*ees0mkl
7741       do ll=1,3
7742 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7743         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7744      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7745      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7746         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7747      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7748      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7749 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7750         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7751      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7752      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7753         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7754      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7755      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7756         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7757      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7758      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7759         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7760         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7761         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7762      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7763      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7764         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7765         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7766 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7767       enddo
7768 c      write (iout,*)
7769 cgrad      do m=i+1,j-1
7770 cgrad        do ll=1,3
7771 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7772 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7773 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7774 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7775 cgrad        enddo
7776 cgrad      enddo
7777 cgrad      do m=k+1,l-1
7778 cgrad        do ll=1,3
7779 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7780 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7781 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7782 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7783 cgrad        enddo
7784 cgrad      enddo
7785 c      write (iout,*) "ehbcorr",ekont*ees
7786       ehbcorr=ekont*ees
7787       return
7788       end
7789 #ifdef MOMENT
7790 C---------------------------------------------------------------------------
7791       subroutine dipole(i,j,jj)
7792       implicit real*8 (a-h,o-z)
7793       include 'DIMENSIONS'
7794       include 'COMMON.IOUNITS'
7795       include 'COMMON.CHAIN'
7796       include 'COMMON.FFIELD'
7797       include 'COMMON.DERIV'
7798       include 'COMMON.INTERACT'
7799       include 'COMMON.CONTACTS'
7800       include 'COMMON.TORSION'
7801       include 'COMMON.VAR'
7802       include 'COMMON.GEO'
7803       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7804      &  auxmat(2,2)
7805       iti1 = itortyp(itype(i+1))
7806       if (j.lt.nres-1) then
7807         itj1 = itortyp(itype(j+1))
7808       else
7809         itj1=ntortyp+1
7810       endif
7811       do iii=1,2
7812         dipi(iii,1)=Ub2(iii,i)
7813         dipderi(iii)=Ub2der(iii,i)
7814         dipi(iii,2)=b1(iii,iti1)
7815         dipj(iii,1)=Ub2(iii,j)
7816         dipderj(iii)=Ub2der(iii,j)
7817         dipj(iii,2)=b1(iii,itj1)
7818       enddo
7819       kkk=0
7820       do iii=1,2
7821         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7822         do jjj=1,2
7823           kkk=kkk+1
7824           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7825         enddo
7826       enddo
7827       do kkk=1,5
7828         do lll=1,3
7829           mmm=0
7830           do iii=1,2
7831             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7832      &        auxvec(1))
7833             do jjj=1,2
7834               mmm=mmm+1
7835               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7836             enddo
7837           enddo
7838         enddo
7839       enddo
7840       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7841       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7842       do iii=1,2
7843         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7844       enddo
7845       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7846       do iii=1,2
7847         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7848       enddo
7849       return
7850       end
7851 #endif
7852 C---------------------------------------------------------------------------
7853       subroutine calc_eello(i,j,k,l,jj,kk)
7854 C
7855 C This subroutine computes matrices and vectors needed to calculate
7856 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7857 C
7858       implicit real*8 (a-h,o-z)
7859       include 'DIMENSIONS'
7860       include 'COMMON.IOUNITS'
7861       include 'COMMON.CHAIN'
7862       include 'COMMON.DERIV'
7863       include 'COMMON.INTERACT'
7864       include 'COMMON.CONTACTS'
7865       include 'COMMON.TORSION'
7866       include 'COMMON.VAR'
7867       include 'COMMON.GEO'
7868       include 'COMMON.FFIELD'
7869       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7870      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7871       logical lprn
7872       common /kutas/ lprn
7873 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7874 cd     & ' jj=',jj,' kk=',kk
7875 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7876 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7877 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7878       do iii=1,2
7879         do jjj=1,2
7880           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7881           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7882         enddo
7883       enddo
7884       call transpose2(aa1(1,1),aa1t(1,1))
7885       call transpose2(aa2(1,1),aa2t(1,1))
7886       do kkk=1,5
7887         do lll=1,3
7888           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7889      &      aa1tder(1,1,lll,kkk))
7890           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7891      &      aa2tder(1,1,lll,kkk))
7892         enddo
7893       enddo
7894       if (l.eq.j+1) then
7895 C parallel orientation of the two CA-CA-CA frames.
7896         if (i.gt.1) then
7897           iti=itortyp(itype(i))
7898         else
7899           iti=ntortyp+1
7900         endif
7901         itk1=itortyp(itype(k+1))
7902         itj=itortyp(itype(j))
7903         if (l.lt.nres-1) then
7904           itl1=itortyp(itype(l+1))
7905         else
7906           itl1=ntortyp+1
7907         endif
7908 C A1 kernel(j+1) A2T
7909 cd        do iii=1,2
7910 cd          write (iout,'(3f10.5,5x,3f10.5)')
7911 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7912 cd        enddo
7913         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7914      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7915      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7916 C Following matrices are needed only for 6-th order cumulants
7917         IF (wcorr6.gt.0.0d0) THEN
7918         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7919      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7920      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7921         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7922      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7923      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7924      &   ADtEAderx(1,1,1,1,1,1))
7925         lprn=.false.
7926         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7927      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7928      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7929      &   ADtEA1derx(1,1,1,1,1,1))
7930         ENDIF
7931 C End 6-th order cumulants
7932 cd        lprn=.false.
7933 cd        if (lprn) then
7934 cd        write (2,*) 'In calc_eello6'
7935 cd        do iii=1,2
7936 cd          write (2,*) 'iii=',iii
7937 cd          do kkk=1,5
7938 cd            write (2,*) 'kkk=',kkk
7939 cd            do jjj=1,2
7940 cd              write (2,'(3(2f10.5),5x)')
7941 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7942 cd            enddo
7943 cd          enddo
7944 cd        enddo
7945 cd        endif
7946         call transpose2(EUgder(1,1,k),auxmat(1,1))
7947         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7948         call transpose2(EUg(1,1,k),auxmat(1,1))
7949         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7950         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7951         do iii=1,2
7952           do kkk=1,5
7953             do lll=1,3
7954               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7955      &          EAEAderx(1,1,lll,kkk,iii,1))
7956             enddo
7957           enddo
7958         enddo
7959 C A1T kernel(i+1) A2
7960         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7961      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7962      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7963 C Following matrices are needed only for 6-th order cumulants
7964         IF (wcorr6.gt.0.0d0) THEN
7965         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7966      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7967      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7968         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7969      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7970      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7971      &   ADtEAderx(1,1,1,1,1,2))
7972         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7973      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7974      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7975      &   ADtEA1derx(1,1,1,1,1,2))
7976         ENDIF
7977 C End 6-th order cumulants
7978         call transpose2(EUgder(1,1,l),auxmat(1,1))
7979         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7980         call transpose2(EUg(1,1,l),auxmat(1,1))
7981         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7982         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7983         do iii=1,2
7984           do kkk=1,5
7985             do lll=1,3
7986               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7987      &          EAEAderx(1,1,lll,kkk,iii,2))
7988             enddo
7989           enddo
7990         enddo
7991 C AEAb1 and AEAb2
7992 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7993 C They are needed only when the fifth- or the sixth-order cumulants are
7994 C indluded.
7995         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7996         call transpose2(AEA(1,1,1),auxmat(1,1))
7997         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7998         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7999         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8000         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8001         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8002         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8003         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8004         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8005         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8006         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8007         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8008         call transpose2(AEA(1,1,2),auxmat(1,1))
8009         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8010         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8011         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8012         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8013         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8014         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8015         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8016         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8017         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8018         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8019         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8020 C Calculate the Cartesian derivatives of the vectors.
8021         do iii=1,2
8022           do kkk=1,5
8023             do lll=1,3
8024               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8025               call matvec2(auxmat(1,1),b1(1,iti),
8026      &          AEAb1derx(1,lll,kkk,iii,1,1))
8027               call matvec2(auxmat(1,1),Ub2(1,i),
8028      &          AEAb2derx(1,lll,kkk,iii,1,1))
8029               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8030      &          AEAb1derx(1,lll,kkk,iii,2,1))
8031               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8032      &          AEAb2derx(1,lll,kkk,iii,2,1))
8033               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8034               call matvec2(auxmat(1,1),b1(1,itj),
8035      &          AEAb1derx(1,lll,kkk,iii,1,2))
8036               call matvec2(auxmat(1,1),Ub2(1,j),
8037      &          AEAb2derx(1,lll,kkk,iii,1,2))
8038               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8039      &          AEAb1derx(1,lll,kkk,iii,2,2))
8040               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8041      &          AEAb2derx(1,lll,kkk,iii,2,2))
8042             enddo
8043           enddo
8044         enddo
8045         ENDIF
8046 C End vectors
8047       else
8048 C Antiparallel orientation of the two CA-CA-CA frames.
8049         if (i.gt.1) then
8050           iti=itortyp(itype(i))
8051         else
8052           iti=ntortyp+1
8053         endif
8054         itk1=itortyp(itype(k+1))
8055         itl=itortyp(itype(l))
8056         itj=itortyp(itype(j))
8057         if (j.lt.nres-1) then
8058           itj1=itortyp(itype(j+1))
8059         else
8060           itj1=ntortyp+1
8061         endif
8062 C A2 kernel(j-1)T A1T
8063         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8064      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8065      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8066 C Following matrices are needed only for 6-th order cumulants
8067         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8068      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8069         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8070      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8071      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8072         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8073      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8074      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8075      &   ADtEAderx(1,1,1,1,1,1))
8076         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8077      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8078      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8079      &   ADtEA1derx(1,1,1,1,1,1))
8080         ENDIF
8081 C End 6-th order cumulants
8082         call transpose2(EUgder(1,1,k),auxmat(1,1))
8083         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8084         call transpose2(EUg(1,1,k),auxmat(1,1))
8085         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8086         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8087         do iii=1,2
8088           do kkk=1,5
8089             do lll=1,3
8090               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8091      &          EAEAderx(1,1,lll,kkk,iii,1))
8092             enddo
8093           enddo
8094         enddo
8095 C A2T kernel(i+1)T A1
8096         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8097      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8098      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8099 C Following matrices are needed only for 6-th order cumulants
8100         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8101      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8102         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8103      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8104      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8105         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8106      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8107      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8108      &   ADtEAderx(1,1,1,1,1,2))
8109         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8110      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8111      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8112      &   ADtEA1derx(1,1,1,1,1,2))
8113         ENDIF
8114 C End 6-th order cumulants
8115         call transpose2(EUgder(1,1,j),auxmat(1,1))
8116         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8117         call transpose2(EUg(1,1,j),auxmat(1,1))
8118         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8119         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8120         do iii=1,2
8121           do kkk=1,5
8122             do lll=1,3
8123               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8124      &          EAEAderx(1,1,lll,kkk,iii,2))
8125             enddo
8126           enddo
8127         enddo
8128 C AEAb1 and AEAb2
8129 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8130 C They are needed only when the fifth- or the sixth-order cumulants are
8131 C indluded.
8132         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8133      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8134         call transpose2(AEA(1,1,1),auxmat(1,1))
8135         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8136         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8137         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8138         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8139         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8140         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8141         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8142         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8143         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8144         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8145         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8146         call transpose2(AEA(1,1,2),auxmat(1,1))
8147         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8148         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8149         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8150         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8151         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8152         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8153         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8154         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8155         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8156         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8157         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8158 C Calculate the Cartesian derivatives of the vectors.
8159         do iii=1,2
8160           do kkk=1,5
8161             do lll=1,3
8162               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8163               call matvec2(auxmat(1,1),b1(1,iti),
8164      &          AEAb1derx(1,lll,kkk,iii,1,1))
8165               call matvec2(auxmat(1,1),Ub2(1,i),
8166      &          AEAb2derx(1,lll,kkk,iii,1,1))
8167               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8168      &          AEAb1derx(1,lll,kkk,iii,2,1))
8169               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8170      &          AEAb2derx(1,lll,kkk,iii,2,1))
8171               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8172               call matvec2(auxmat(1,1),b1(1,itl),
8173      &          AEAb1derx(1,lll,kkk,iii,1,2))
8174               call matvec2(auxmat(1,1),Ub2(1,l),
8175      &          AEAb2derx(1,lll,kkk,iii,1,2))
8176               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
8177      &          AEAb1derx(1,lll,kkk,iii,2,2))
8178               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8179      &          AEAb2derx(1,lll,kkk,iii,2,2))
8180             enddo
8181           enddo
8182         enddo
8183         ENDIF
8184 C End vectors
8185       endif
8186       return
8187       end
8188 C---------------------------------------------------------------------------
8189       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8190      &  KK,KKderg,AKA,AKAderg,AKAderx)
8191       implicit none
8192       integer nderg
8193       logical transp
8194       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8195      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8196      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8197       integer iii,kkk,lll
8198       integer jjj,mmm
8199       logical lprn
8200       common /kutas/ lprn
8201       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8202       do iii=1,nderg
8203         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8204      &    AKAderg(1,1,iii))
8205       enddo
8206 cd      if (lprn) write (2,*) 'In kernel'
8207       do kkk=1,5
8208 cd        if (lprn) write (2,*) 'kkk=',kkk
8209         do lll=1,3
8210           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8211      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8212 cd          if (lprn) then
8213 cd            write (2,*) 'lll=',lll
8214 cd            write (2,*) 'iii=1'
8215 cd            do jjj=1,2
8216 cd              write (2,'(3(2f10.5),5x)')
8217 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8218 cd            enddo
8219 cd          endif
8220           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8221      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8222 cd          if (lprn) then
8223 cd            write (2,*) 'lll=',lll
8224 cd            write (2,*) 'iii=2'
8225 cd            do jjj=1,2
8226 cd              write (2,'(3(2f10.5),5x)')
8227 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8228 cd            enddo
8229 cd          endif
8230         enddo
8231       enddo
8232       return
8233       end
8234 C---------------------------------------------------------------------------
8235       double precision function eello4(i,j,k,l,jj,kk)
8236       implicit real*8 (a-h,o-z)
8237       include 'DIMENSIONS'
8238       include 'COMMON.IOUNITS'
8239       include 'COMMON.CHAIN'
8240       include 'COMMON.DERIV'
8241       include 'COMMON.INTERACT'
8242       include 'COMMON.CONTACTS'
8243       include 'COMMON.TORSION'
8244       include 'COMMON.VAR'
8245       include 'COMMON.GEO'
8246       double precision pizda(2,2),ggg1(3),ggg2(3)
8247 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8248 cd        eello4=0.0d0
8249 cd        return
8250 cd      endif
8251 cd      print *,'eello4:',i,j,k,l,jj,kk
8252 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8253 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8254 cold      eij=facont_hb(jj,i)
8255 cold      ekl=facont_hb(kk,k)
8256 cold      ekont=eij*ekl
8257       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8258 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8259       gcorr_loc(k-1)=gcorr_loc(k-1)
8260      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8261       if (l.eq.j+1) then
8262         gcorr_loc(l-1)=gcorr_loc(l-1)
8263      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8264       else
8265         gcorr_loc(j-1)=gcorr_loc(j-1)
8266      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8267       endif
8268       do iii=1,2
8269         do kkk=1,5
8270           do lll=1,3
8271             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8272      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8273 cd            derx(lll,kkk,iii)=0.0d0
8274           enddo
8275         enddo
8276       enddo
8277 cd      gcorr_loc(l-1)=0.0d0
8278 cd      gcorr_loc(j-1)=0.0d0
8279 cd      gcorr_loc(k-1)=0.0d0
8280 cd      eel4=1.0d0
8281 cd      write (iout,*)'Contacts have occurred for peptide groups',
8282 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8283 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8284       if (j.lt.nres-1) then
8285         j1=j+1
8286         j2=j-1
8287       else
8288         j1=j-1
8289         j2=j-2
8290       endif
8291       if (l.lt.nres-1) then
8292         l1=l+1
8293         l2=l-1
8294       else
8295         l1=l-1
8296         l2=l-2
8297       endif
8298       do ll=1,3
8299 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8300 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8301         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8302         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8303 cgrad        ghalf=0.5d0*ggg1(ll)
8304         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8305         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8306         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8307         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8308         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8309         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8310 cgrad        ghalf=0.5d0*ggg2(ll)
8311         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8312         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8313         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8314         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8315         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8316         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8317       enddo
8318 cgrad      do m=i+1,j-1
8319 cgrad        do ll=1,3
8320 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8321 cgrad        enddo
8322 cgrad      enddo
8323 cgrad      do m=k+1,l-1
8324 cgrad        do ll=1,3
8325 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8326 cgrad        enddo
8327 cgrad      enddo
8328 cgrad      do m=i+2,j2
8329 cgrad        do ll=1,3
8330 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8331 cgrad        enddo
8332 cgrad      enddo
8333 cgrad      do m=k+2,l2
8334 cgrad        do ll=1,3
8335 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8336 cgrad        enddo
8337 cgrad      enddo
8338 cd      do iii=1,nres-3
8339 cd        write (2,*) iii,gcorr_loc(iii)
8340 cd      enddo
8341       eello4=ekont*eel4
8342 cd      write (2,*) 'ekont',ekont
8343 cd      write (iout,*) 'eello4',ekont*eel4
8344       return
8345       end
8346 C---------------------------------------------------------------------------
8347       double precision function eello5(i,j,k,l,jj,kk)
8348       implicit real*8 (a-h,o-z)
8349       include 'DIMENSIONS'
8350       include 'COMMON.IOUNITS'
8351       include 'COMMON.CHAIN'
8352       include 'COMMON.DERIV'
8353       include 'COMMON.INTERACT'
8354       include 'COMMON.CONTACTS'
8355       include 'COMMON.TORSION'
8356       include 'COMMON.VAR'
8357       include 'COMMON.GEO'
8358       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8359       double precision ggg1(3),ggg2(3)
8360 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8361 C                                                                              C
8362 C                            Parallel chains                                   C
8363 C                                                                              C
8364 C          o             o                   o             o                   C
8365 C         /l\           / \             \   / \           / \   /              C
8366 C        /   \         /   \             \ /   \         /   \ /               C
8367 C       j| o |l1       | o |              o| o |         | o |o                C
8368 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8369 C      \i/   \         /   \ /             /   \         /   \                 C
8370 C       o    k1             o                                                  C
8371 C         (I)          (II)                (III)          (IV)                 C
8372 C                                                                              C
8373 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8374 C                                                                              C
8375 C                            Antiparallel chains                               C
8376 C                                                                              C
8377 C          o             o                   o             o                   C
8378 C         /j\           / \             \   / \           / \   /              C
8379 C        /   \         /   \             \ /   \         /   \ /               C
8380 C      j1| o |l        | o |              o| o |         | o |o                C
8381 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8382 C      \i/   \         /   \ /             /   \         /   \                 C
8383 C       o     k1            o                                                  C
8384 C         (I)          (II)                (III)          (IV)                 C
8385 C                                                                              C
8386 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8387 C                                                                              C
8388 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8389 C                                                                              C
8390 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8391 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8392 cd        eello5=0.0d0
8393 cd        return
8394 cd      endif
8395 cd      write (iout,*)
8396 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8397 cd     &   ' and',k,l
8398       itk=itortyp(itype(k))
8399       itl=itortyp(itype(l))
8400       itj=itortyp(itype(j))
8401       eello5_1=0.0d0
8402       eello5_2=0.0d0
8403       eello5_3=0.0d0
8404       eello5_4=0.0d0
8405 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8406 cd     &   eel5_3_num,eel5_4_num)
8407       do iii=1,2
8408         do kkk=1,5
8409           do lll=1,3
8410             derx(lll,kkk,iii)=0.0d0
8411           enddo
8412         enddo
8413       enddo
8414 cd      eij=facont_hb(jj,i)
8415 cd      ekl=facont_hb(kk,k)
8416 cd      ekont=eij*ekl
8417 cd      write (iout,*)'Contacts have occurred for peptide groups',
8418 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8419 cd      goto 1111
8420 C Contribution from the graph I.
8421 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8422 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8423       call transpose2(EUg(1,1,k),auxmat(1,1))
8424       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8425       vv(1)=pizda(1,1)-pizda(2,2)
8426       vv(2)=pizda(1,2)+pizda(2,1)
8427       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8428      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8429 C Explicit gradient in virtual-dihedral angles.
8430       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8431      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8432      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8433       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8434       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8435       vv(1)=pizda(1,1)-pizda(2,2)
8436       vv(2)=pizda(1,2)+pizda(2,1)
8437       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8438      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8439      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8440       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8441       vv(1)=pizda(1,1)-pizda(2,2)
8442       vv(2)=pizda(1,2)+pizda(2,1)
8443       if (l.eq.j+1) then
8444         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8445      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8446      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8447       else
8448         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8449      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8450      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8451       endif
8452 C Cartesian gradient
8453       do iii=1,2
8454         do kkk=1,5
8455           do lll=1,3
8456             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8457      &        pizda(1,1))
8458             vv(1)=pizda(1,1)-pizda(2,2)
8459             vv(2)=pizda(1,2)+pizda(2,1)
8460             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8461      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8462      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8463           enddo
8464         enddo
8465       enddo
8466 c      goto 1112
8467 c1111  continue
8468 C Contribution from graph II
8469       call transpose2(EE(1,1,itk),auxmat(1,1))
8470       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8471       vv(1)=pizda(1,1)+pizda(2,2)
8472       vv(2)=pizda(2,1)-pizda(1,2)
8473       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8474      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8475 C Explicit gradient in virtual-dihedral angles.
8476       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8477      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8478       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8479       vv(1)=pizda(1,1)+pizda(2,2)
8480       vv(2)=pizda(2,1)-pizda(1,2)
8481       if (l.eq.j+1) then
8482         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8483      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8484      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8485       else
8486         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8487      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8488      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8489       endif
8490 C Cartesian gradient
8491       do iii=1,2
8492         do kkk=1,5
8493           do lll=1,3
8494             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8495      &        pizda(1,1))
8496             vv(1)=pizda(1,1)+pizda(2,2)
8497             vv(2)=pizda(2,1)-pizda(1,2)
8498             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8499      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8500      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8501           enddo
8502         enddo
8503       enddo
8504 cd      goto 1112
8505 cd1111  continue
8506       if (l.eq.j+1) then
8507 cd        goto 1110
8508 C Parallel orientation
8509 C Contribution from graph III
8510         call transpose2(EUg(1,1,l),auxmat(1,1))
8511         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8512         vv(1)=pizda(1,1)-pizda(2,2)
8513         vv(2)=pizda(1,2)+pizda(2,1)
8514         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8515      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8516 C Explicit gradient in virtual-dihedral angles.
8517         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8518      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8519      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8520         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8521         vv(1)=pizda(1,1)-pizda(2,2)
8522         vv(2)=pizda(1,2)+pizda(2,1)
8523         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8524      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8525      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8526         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8527         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8528         vv(1)=pizda(1,1)-pizda(2,2)
8529         vv(2)=pizda(1,2)+pizda(2,1)
8530         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8531      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8532      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8533 C Cartesian gradient
8534         do iii=1,2
8535           do kkk=1,5
8536             do lll=1,3
8537               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8538      &          pizda(1,1))
8539               vv(1)=pizda(1,1)-pizda(2,2)
8540               vv(2)=pizda(1,2)+pizda(2,1)
8541               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8542      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8543      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8544             enddo
8545           enddo
8546         enddo
8547 cd        goto 1112
8548 C Contribution from graph IV
8549 cd1110    continue
8550         call transpose2(EE(1,1,itl),auxmat(1,1))
8551         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8552         vv(1)=pizda(1,1)+pizda(2,2)
8553         vv(2)=pizda(2,1)-pizda(1,2)
8554         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8555      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8556 C Explicit gradient in virtual-dihedral angles.
8557         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8558      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8559         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8560         vv(1)=pizda(1,1)+pizda(2,2)
8561         vv(2)=pizda(2,1)-pizda(1,2)
8562         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8563      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8564      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8565 C Cartesian gradient
8566         do iii=1,2
8567           do kkk=1,5
8568             do lll=1,3
8569               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8570      &          pizda(1,1))
8571               vv(1)=pizda(1,1)+pizda(2,2)
8572               vv(2)=pizda(2,1)-pizda(1,2)
8573               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8574      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8575      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8576             enddo
8577           enddo
8578         enddo
8579       else
8580 C Antiparallel orientation
8581 C Contribution from graph III
8582 c        goto 1110
8583         call transpose2(EUg(1,1,j),auxmat(1,1))
8584         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8585         vv(1)=pizda(1,1)-pizda(2,2)
8586         vv(2)=pizda(1,2)+pizda(2,1)
8587         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8588      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8589 C Explicit gradient in virtual-dihedral angles.
8590         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8591      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8592      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8593         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8594         vv(1)=pizda(1,1)-pizda(2,2)
8595         vv(2)=pizda(1,2)+pizda(2,1)
8596         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8597      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8598      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8599         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8600         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8601         vv(1)=pizda(1,1)-pizda(2,2)
8602         vv(2)=pizda(1,2)+pizda(2,1)
8603         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8604      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8605      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8606 C Cartesian gradient
8607         do iii=1,2
8608           do kkk=1,5
8609             do lll=1,3
8610               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8611      &          pizda(1,1))
8612               vv(1)=pizda(1,1)-pizda(2,2)
8613               vv(2)=pizda(1,2)+pizda(2,1)
8614               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8615      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8616      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8617             enddo
8618           enddo
8619         enddo
8620 cd        goto 1112
8621 C Contribution from graph IV
8622 1110    continue
8623         call transpose2(EE(1,1,itj),auxmat(1,1))
8624         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8625         vv(1)=pizda(1,1)+pizda(2,2)
8626         vv(2)=pizda(2,1)-pizda(1,2)
8627         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8628      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8629 C Explicit gradient in virtual-dihedral angles.
8630         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8631      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8632         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8633         vv(1)=pizda(1,1)+pizda(2,2)
8634         vv(2)=pizda(2,1)-pizda(1,2)
8635         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8636      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8637      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8638 C Cartesian gradient
8639         do iii=1,2
8640           do kkk=1,5
8641             do lll=1,3
8642               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8643      &          pizda(1,1))
8644               vv(1)=pizda(1,1)+pizda(2,2)
8645               vv(2)=pizda(2,1)-pizda(1,2)
8646               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8647      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8648      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8649             enddo
8650           enddo
8651         enddo
8652       endif
8653 1112  continue
8654       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8655 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8656 cd        write (2,*) 'ijkl',i,j,k,l
8657 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8658 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8659 cd      endif
8660 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8661 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8662 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8663 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8664       if (j.lt.nres-1) then
8665         j1=j+1
8666         j2=j-1
8667       else
8668         j1=j-1
8669         j2=j-2
8670       endif
8671       if (l.lt.nres-1) then
8672         l1=l+1
8673         l2=l-1
8674       else
8675         l1=l-1
8676         l2=l-2
8677       endif
8678 cd      eij=1.0d0
8679 cd      ekl=1.0d0
8680 cd      ekont=1.0d0
8681 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8682 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8683 C        summed up outside the subrouine as for the other subroutines
8684 C        handling long-range interactions. The old code is commented out
8685 C        with "cgrad" to keep track of changes.
8686       do ll=1,3
8687 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8688 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8689         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8690         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8691 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8692 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8693 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8694 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8695 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8696 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8697 c     &   gradcorr5ij,
8698 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8699 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8700 cgrad        ghalf=0.5d0*ggg1(ll)
8701 cd        ghalf=0.0d0
8702         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8703         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8704         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8705         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8706         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8707         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8708 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8709 cgrad        ghalf=0.5d0*ggg2(ll)
8710 cd        ghalf=0.0d0
8711         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8712         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8713         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8714         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8715         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8716         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8717       enddo
8718 cd      goto 1112
8719 cgrad      do m=i+1,j-1
8720 cgrad        do ll=1,3
8721 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8722 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8723 cgrad        enddo
8724 cgrad      enddo
8725 cgrad      do m=k+1,l-1
8726 cgrad        do ll=1,3
8727 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8728 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8729 cgrad        enddo
8730 cgrad      enddo
8731 c1112  continue
8732 cgrad      do m=i+2,j2
8733 cgrad        do ll=1,3
8734 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8735 cgrad        enddo
8736 cgrad      enddo
8737 cgrad      do m=k+2,l2
8738 cgrad        do ll=1,3
8739 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8740 cgrad        enddo
8741 cgrad      enddo
8742 cd      do iii=1,nres-3
8743 cd        write (2,*) iii,g_corr5_loc(iii)
8744 cd      enddo
8745       eello5=ekont*eel5
8746 cd      write (2,*) 'ekont',ekont
8747 cd      write (iout,*) 'eello5',ekont*eel5
8748       return
8749       end
8750 c--------------------------------------------------------------------------
8751       double precision function eello6(i,j,k,l,jj,kk)
8752       implicit real*8 (a-h,o-z)
8753       include 'DIMENSIONS'
8754       include 'COMMON.IOUNITS'
8755       include 'COMMON.CHAIN'
8756       include 'COMMON.DERIV'
8757       include 'COMMON.INTERACT'
8758       include 'COMMON.CONTACTS'
8759       include 'COMMON.TORSION'
8760       include 'COMMON.VAR'
8761       include 'COMMON.GEO'
8762       include 'COMMON.FFIELD'
8763       double precision ggg1(3),ggg2(3)
8764 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8765 cd        eello6=0.0d0
8766 cd        return
8767 cd      endif
8768 cd      write (iout,*)
8769 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8770 cd     &   ' and',k,l
8771       eello6_1=0.0d0
8772       eello6_2=0.0d0
8773       eello6_3=0.0d0
8774       eello6_4=0.0d0
8775       eello6_5=0.0d0
8776       eello6_6=0.0d0
8777 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8778 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8779       do iii=1,2
8780         do kkk=1,5
8781           do lll=1,3
8782             derx(lll,kkk,iii)=0.0d0
8783           enddo
8784         enddo
8785       enddo
8786 cd      eij=facont_hb(jj,i)
8787 cd      ekl=facont_hb(kk,k)
8788 cd      ekont=eij*ekl
8789 cd      eij=1.0d0
8790 cd      ekl=1.0d0
8791 cd      ekont=1.0d0
8792       if (l.eq.j+1) then
8793         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8794         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8795         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8796         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8797         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8798         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8799       else
8800         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8801         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8802         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8803         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8804         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8805           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8806         else
8807           eello6_5=0.0d0
8808         endif
8809         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8810       endif
8811 C If turn contributions are considered, they will be handled separately.
8812       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8813 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8814 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8815 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8816 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8817 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8818 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8819 cd      goto 1112
8820       if (j.lt.nres-1) then
8821         j1=j+1
8822         j2=j-1
8823       else
8824         j1=j-1
8825         j2=j-2
8826       endif
8827       if (l.lt.nres-1) then
8828         l1=l+1
8829         l2=l-1
8830       else
8831         l1=l-1
8832         l2=l-2
8833       endif
8834       do ll=1,3
8835 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8836 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8837 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8838 cgrad        ghalf=0.5d0*ggg1(ll)
8839 cd        ghalf=0.0d0
8840         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8841         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8842         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8843         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8844         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8845         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8846         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8847         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8848 cgrad        ghalf=0.5d0*ggg2(ll)
8849 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8850 cd        ghalf=0.0d0
8851         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8852         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8853         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8854         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8855         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8856         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8857       enddo
8858 cd      goto 1112
8859 cgrad      do m=i+1,j-1
8860 cgrad        do ll=1,3
8861 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8862 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8863 cgrad        enddo
8864 cgrad      enddo
8865 cgrad      do m=k+1,l-1
8866 cgrad        do ll=1,3
8867 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8868 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8869 cgrad        enddo
8870 cgrad      enddo
8871 cgrad1112  continue
8872 cgrad      do m=i+2,j2
8873 cgrad        do ll=1,3
8874 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8875 cgrad        enddo
8876 cgrad      enddo
8877 cgrad      do m=k+2,l2
8878 cgrad        do ll=1,3
8879 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8880 cgrad        enddo
8881 cgrad      enddo
8882 cd      do iii=1,nres-3
8883 cd        write (2,*) iii,g_corr6_loc(iii)
8884 cd      enddo
8885       eello6=ekont*eel6
8886 cd      write (2,*) 'ekont',ekont
8887 cd      write (iout,*) 'eello6',ekont*eel6
8888       return
8889       end
8890 c--------------------------------------------------------------------------
8891       double precision function eello6_graph1(i,j,k,l,imat,swap)
8892       implicit real*8 (a-h,o-z)
8893       include 'DIMENSIONS'
8894       include 'COMMON.IOUNITS'
8895       include 'COMMON.CHAIN'
8896       include 'COMMON.DERIV'
8897       include 'COMMON.INTERACT'
8898       include 'COMMON.CONTACTS'
8899       include 'COMMON.TORSION'
8900       include 'COMMON.VAR'
8901       include 'COMMON.GEO'
8902       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8903       logical swap
8904       logical lprn
8905       common /kutas/ lprn
8906 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8907 C
8908 C      Parallel       Antiparallel
8909 C
8910 C          o             o
8911 C         /l\           /j\
8912 C        /   \         /   \
8913 C       /| o |         | o |\
8914 C     \ j|/k\|  /   \  |/k\|l /
8915 C      \ /   \ /     \ /   \ /
8916 C       o     o       o     o
8917 C       i             i
8918 C
8919 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8920       itk=itortyp(itype(k))
8921       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8922       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8923       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8924       call transpose2(EUgC(1,1,k),auxmat(1,1))
8925       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8926       vv1(1)=pizda1(1,1)-pizda1(2,2)
8927       vv1(2)=pizda1(1,2)+pizda1(2,1)
8928       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8929       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8930       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8931       s5=scalar2(vv(1),Dtobr2(1,i))
8932 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8933       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8934       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8935      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8936      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8937      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8938      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8939      & +scalar2(vv(1),Dtobr2der(1,i)))
8940       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8941       vv1(1)=pizda1(1,1)-pizda1(2,2)
8942       vv1(2)=pizda1(1,2)+pizda1(2,1)
8943       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8944       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8945       if (l.eq.j+1) then
8946         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8947      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8948      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8949      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8950      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8951       else
8952         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8953      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8954      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8955      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8956      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8957       endif
8958       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8959       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8960       vv1(1)=pizda1(1,1)-pizda1(2,2)
8961       vv1(2)=pizda1(1,2)+pizda1(2,1)
8962       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8963      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8964      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8965      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8966       do iii=1,2
8967         if (swap) then
8968           ind=3-iii
8969         else
8970           ind=iii
8971         endif
8972         do kkk=1,5
8973           do lll=1,3
8974             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8975             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8976             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8977             call transpose2(EUgC(1,1,k),auxmat(1,1))
8978             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8979      &        pizda1(1,1))
8980             vv1(1)=pizda1(1,1)-pizda1(2,2)
8981             vv1(2)=pizda1(1,2)+pizda1(2,1)
8982             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8983             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8984      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8985             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8986      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8987             s5=scalar2(vv(1),Dtobr2(1,i))
8988             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8989           enddo
8990         enddo
8991       enddo
8992       return
8993       end
8994 c----------------------------------------------------------------------------
8995       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8996       implicit real*8 (a-h,o-z)
8997       include 'DIMENSIONS'
8998       include 'COMMON.IOUNITS'
8999       include 'COMMON.CHAIN'
9000       include 'COMMON.DERIV'
9001       include 'COMMON.INTERACT'
9002       include 'COMMON.CONTACTS'
9003       include 'COMMON.TORSION'
9004       include 'COMMON.VAR'
9005       include 'COMMON.GEO'
9006       logical swap
9007       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9008      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9009       logical lprn
9010       common /kutas/ lprn
9011 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9012 C                                                                              C
9013 C      Parallel       Antiparallel                                             C
9014 C                                                                              C
9015 C          o             o                                                     C
9016 C     \   /l\           /j\   /                                                C
9017 C      \ /   \         /   \ /                                                 C
9018 C       o| o |         | o |o                                                  C
9019 C     \ j|/k\|      \  |/k\|l                                                  C
9020 C      \ /   \       \ /   \                                                   C
9021 C       o             o                                                        C
9022 C       i             i                                                        C
9023 C                                                                              C
9024 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9025 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9026 C AL 7/4/01 s1 would occur in the sixth-order moment,
9027 C           but not in a cluster cumulant
9028 #ifdef MOMENT
9029       s1=dip(1,jj,i)*dip(1,kk,k)
9030 #endif
9031       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9032       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9033       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9034       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9035       call transpose2(EUg(1,1,k),auxmat(1,1))
9036       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9037       vv(1)=pizda(1,1)-pizda(2,2)
9038       vv(2)=pizda(1,2)+pizda(2,1)
9039       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9040 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9041 #ifdef MOMENT
9042       eello6_graph2=-(s1+s2+s3+s4)
9043 #else
9044       eello6_graph2=-(s2+s3+s4)
9045 #endif
9046 c      eello6_graph2=-s3
9047 C Derivatives in gamma(i-1)
9048       if (i.gt.1) then
9049 #ifdef MOMENT
9050         s1=dipderg(1,jj,i)*dip(1,kk,k)
9051 #endif
9052         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9053         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9054         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9055         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9056 #ifdef MOMENT
9057         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9058 #else
9059         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9060 #endif
9061 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9062       endif
9063 C Derivatives in gamma(k-1)
9064 #ifdef MOMENT
9065       s1=dip(1,jj,i)*dipderg(1,kk,k)
9066 #endif
9067       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9068       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9069       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9070       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9071       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9072       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9073       vv(1)=pizda(1,1)-pizda(2,2)
9074       vv(2)=pizda(1,2)+pizda(2,1)
9075       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9076 #ifdef MOMENT
9077       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9078 #else
9079       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9080 #endif
9081 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9082 C Derivatives in gamma(j-1) or gamma(l-1)
9083       if (j.gt.1) then
9084 #ifdef MOMENT
9085         s1=dipderg(3,jj,i)*dip(1,kk,k)
9086 #endif
9087         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9088         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9089         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9090         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9091         vv(1)=pizda(1,1)-pizda(2,2)
9092         vv(2)=pizda(1,2)+pizda(2,1)
9093         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9094 #ifdef MOMENT
9095         if (swap) then
9096           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9097         else
9098           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9099         endif
9100 #endif
9101         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9102 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9103       endif
9104 C Derivatives in gamma(l-1) or gamma(j-1)
9105       if (l.gt.1) then
9106 #ifdef MOMENT
9107         s1=dip(1,jj,i)*dipderg(3,kk,k)
9108 #endif
9109         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9110         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9111         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9112         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9113         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9114         vv(1)=pizda(1,1)-pizda(2,2)
9115         vv(2)=pizda(1,2)+pizda(2,1)
9116         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9117 #ifdef MOMENT
9118         if (swap) then
9119           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9120         else
9121           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9122         endif
9123 #endif
9124         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9125 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9126       endif
9127 C Cartesian derivatives.
9128       if (lprn) then
9129         write (2,*) 'In eello6_graph2'
9130         do iii=1,2
9131           write (2,*) 'iii=',iii
9132           do kkk=1,5
9133             write (2,*) 'kkk=',kkk
9134             do jjj=1,2
9135               write (2,'(3(2f10.5),5x)')
9136      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9137             enddo
9138           enddo
9139         enddo
9140       endif
9141       do iii=1,2
9142         do kkk=1,5
9143           do lll=1,3
9144 #ifdef MOMENT
9145             if (iii.eq.1) then
9146               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9147             else
9148               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9149             endif
9150 #endif
9151             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9152      &        auxvec(1))
9153             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9154             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9155      &        auxvec(1))
9156             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9157             call transpose2(EUg(1,1,k),auxmat(1,1))
9158             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9159      &        pizda(1,1))
9160             vv(1)=pizda(1,1)-pizda(2,2)
9161             vv(2)=pizda(1,2)+pizda(2,1)
9162             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9163 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9164 #ifdef MOMENT
9165             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9166 #else
9167             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9168 #endif
9169             if (swap) then
9170               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9171             else
9172               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9173             endif
9174           enddo
9175         enddo
9176       enddo
9177       return
9178       end
9179 c----------------------------------------------------------------------------
9180       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9181       implicit real*8 (a-h,o-z)
9182       include 'DIMENSIONS'
9183       include 'COMMON.IOUNITS'
9184       include 'COMMON.CHAIN'
9185       include 'COMMON.DERIV'
9186       include 'COMMON.INTERACT'
9187       include 'COMMON.CONTACTS'
9188       include 'COMMON.TORSION'
9189       include 'COMMON.VAR'
9190       include 'COMMON.GEO'
9191       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9192       logical swap
9193 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9194 C                                                                              C
9195 C      Parallel       Antiparallel                                             C
9196 C                                                                              C
9197 C          o             o                                                     C
9198 C         /l\   /   \   /j\                                                    C
9199 C        /   \ /     \ /   \                                                   C
9200 C       /| o |o       o| o |\                                                  C
9201 C       j|/k\|  /      |/k\|l /                                                C
9202 C        /   \ /       /   \ /                                                 C
9203 C       /     o       /     o                                                  C
9204 C       i             i                                                        C
9205 C                                                                              C
9206 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9207 C
9208 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9209 C           energy moment and not to the cluster cumulant.
9210       iti=itortyp(itype(i))
9211       if (j.lt.nres-1) then
9212         itj1=itortyp(itype(j+1))
9213       else
9214         itj1=ntortyp+1
9215       endif
9216       itk=itortyp(itype(k))
9217       itk1=itortyp(itype(k+1))
9218       if (l.lt.nres-1) then
9219         itl1=itortyp(itype(l+1))
9220       else
9221         itl1=ntortyp+1
9222       endif
9223 #ifdef MOMENT
9224       s1=dip(4,jj,i)*dip(4,kk,k)
9225 #endif
9226       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9227       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9228       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9229       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9230       call transpose2(EE(1,1,itk),auxmat(1,1))
9231       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9232       vv(1)=pizda(1,1)+pizda(2,2)
9233       vv(2)=pizda(2,1)-pizda(1,2)
9234       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9235 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9236 cd     & "sum",-(s2+s3+s4)
9237 #ifdef MOMENT
9238       eello6_graph3=-(s1+s2+s3+s4)
9239 #else
9240       eello6_graph3=-(s2+s3+s4)
9241 #endif
9242 c      eello6_graph3=-s4
9243 C Derivatives in gamma(k-1)
9244       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9245       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9246       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9247       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9248 C Derivatives in gamma(l-1)
9249       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9250       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9251       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9252       vv(1)=pizda(1,1)+pizda(2,2)
9253       vv(2)=pizda(2,1)-pizda(1,2)
9254       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9255       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9256 C Cartesian derivatives.
9257       do iii=1,2
9258         do kkk=1,5
9259           do lll=1,3
9260 #ifdef MOMENT
9261             if (iii.eq.1) then
9262               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9263             else
9264               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9265             endif
9266 #endif
9267             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
9268      &        auxvec(1))
9269             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9270             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
9271      &        auxvec(1))
9272             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9273             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9274      &        pizda(1,1))
9275             vv(1)=pizda(1,1)+pizda(2,2)
9276             vv(2)=pizda(2,1)-pizda(1,2)
9277             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9278 #ifdef MOMENT
9279             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9280 #else
9281             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9282 #endif
9283             if (swap) then
9284               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9285             else
9286               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9287             endif
9288 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9289           enddo
9290         enddo
9291       enddo
9292       return
9293       end
9294 c----------------------------------------------------------------------------
9295       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9296       implicit real*8 (a-h,o-z)
9297       include 'DIMENSIONS'
9298       include 'COMMON.IOUNITS'
9299       include 'COMMON.CHAIN'
9300       include 'COMMON.DERIV'
9301       include 'COMMON.INTERACT'
9302       include 'COMMON.CONTACTS'
9303       include 'COMMON.TORSION'
9304       include 'COMMON.VAR'
9305       include 'COMMON.GEO'
9306       include 'COMMON.FFIELD'
9307       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9308      & auxvec1(2),auxmat1(2,2)
9309       logical swap
9310 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9311 C                                                                              C
9312 C      Parallel       Antiparallel                                             C
9313 C                                                                              C
9314 C          o             o                                                     C
9315 C         /l\   /   \   /j\                                                    C
9316 C        /   \ /     \ /   \                                                   C
9317 C       /| o |o       o| o |\                                                  C
9318 C     \ j|/k\|      \  |/k\|l                                                  C
9319 C      \ /   \       \ /   \                                                   C
9320 C       o     \       o     \                                                  C
9321 C       i             i                                                        C
9322 C                                                                              C
9323 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9324 C
9325 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9326 C           energy moment and not to the cluster cumulant.
9327 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9328       iti=itortyp(itype(i))
9329       itj=itortyp(itype(j))
9330       if (j.lt.nres-1) then
9331         itj1=itortyp(itype(j+1))
9332       else
9333         itj1=ntortyp+1
9334       endif
9335       itk=itortyp(itype(k))
9336       if (k.lt.nres-1) then
9337         itk1=itortyp(itype(k+1))
9338       else
9339         itk1=ntortyp+1
9340       endif
9341       itl=itortyp(itype(l))
9342       if (l.lt.nres-1) then
9343         itl1=itortyp(itype(l+1))
9344       else
9345         itl1=ntortyp+1
9346       endif
9347 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9348 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9349 cd     & ' itl',itl,' itl1',itl1
9350 #ifdef MOMENT
9351       if (imat.eq.1) then
9352         s1=dip(3,jj,i)*dip(3,kk,k)
9353       else
9354         s1=dip(2,jj,j)*dip(2,kk,l)
9355       endif
9356 #endif
9357       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9358       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9359       if (j.eq.l+1) then
9360         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9361         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9362       else
9363         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9364         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9365       endif
9366       call transpose2(EUg(1,1,k),auxmat(1,1))
9367       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9368       vv(1)=pizda(1,1)-pizda(2,2)
9369       vv(2)=pizda(2,1)+pizda(1,2)
9370       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9371 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9372 #ifdef MOMENT
9373       eello6_graph4=-(s1+s2+s3+s4)
9374 #else
9375       eello6_graph4=-(s2+s3+s4)
9376 #endif
9377 C Derivatives in gamma(i-1)
9378       if (i.gt.1) then
9379 #ifdef MOMENT
9380         if (imat.eq.1) then
9381           s1=dipderg(2,jj,i)*dip(3,kk,k)
9382         else
9383           s1=dipderg(4,jj,j)*dip(2,kk,l)
9384         endif
9385 #endif
9386         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9387         if (j.eq.l+1) then
9388           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9389           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9390         else
9391           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9392           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9393         endif
9394         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9395         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9396 cd          write (2,*) 'turn6 derivatives'
9397 #ifdef MOMENT
9398           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9399 #else
9400           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9401 #endif
9402         else
9403 #ifdef MOMENT
9404           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9405 #else
9406           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9407 #endif
9408         endif
9409       endif
9410 C Derivatives in gamma(k-1)
9411 #ifdef MOMENT
9412       if (imat.eq.1) then
9413         s1=dip(3,jj,i)*dipderg(2,kk,k)
9414       else
9415         s1=dip(2,jj,j)*dipderg(4,kk,l)
9416       endif
9417 #endif
9418       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9419       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9420       if (j.eq.l+1) then
9421         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9422         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9423       else
9424         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9425         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9426       endif
9427       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9428       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9429       vv(1)=pizda(1,1)-pizda(2,2)
9430       vv(2)=pizda(2,1)+pizda(1,2)
9431       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9432       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9433 #ifdef MOMENT
9434         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9435 #else
9436         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9437 #endif
9438       else
9439 #ifdef MOMENT
9440         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9441 #else
9442         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9443 #endif
9444       endif
9445 C Derivatives in gamma(j-1) or gamma(l-1)
9446       if (l.eq.j+1 .and. l.gt.1) then
9447         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9448         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9449         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9450         vv(1)=pizda(1,1)-pizda(2,2)
9451         vv(2)=pizda(2,1)+pizda(1,2)
9452         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9453         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9454       else if (j.gt.1) then
9455         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9456         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9457         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9458         vv(1)=pizda(1,1)-pizda(2,2)
9459         vv(2)=pizda(2,1)+pizda(1,2)
9460         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9461         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9462           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9463         else
9464           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9465         endif
9466       endif
9467 C Cartesian derivatives.
9468       do iii=1,2
9469         do kkk=1,5
9470           do lll=1,3
9471 #ifdef MOMENT
9472             if (iii.eq.1) then
9473               if (imat.eq.1) then
9474                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9475               else
9476                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9477               endif
9478             else
9479               if (imat.eq.1) then
9480                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9481               else
9482                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9483               endif
9484             endif
9485 #endif
9486             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9487      &        auxvec(1))
9488             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9489             if (j.eq.l+1) then
9490               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9491      &          b1(1,itj1),auxvec(1))
9492               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9493             else
9494               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9495      &          b1(1,itl1),auxvec(1))
9496               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9497             endif
9498             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9499      &        pizda(1,1))
9500             vv(1)=pizda(1,1)-pizda(2,2)
9501             vv(2)=pizda(2,1)+pizda(1,2)
9502             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9503             if (swap) then
9504               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9505 #ifdef MOMENT
9506                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9507      &             -(s1+s2+s4)
9508 #else
9509                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9510      &             -(s2+s4)
9511 #endif
9512                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9513               else
9514 #ifdef MOMENT
9515                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9516 #else
9517                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9518 #endif
9519                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9520               endif
9521             else
9522 #ifdef MOMENT
9523               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9524 #else
9525               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9526 #endif
9527               if (l.eq.j+1) then
9528                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9529               else
9530                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9531               endif
9532             endif
9533           enddo
9534         enddo
9535       enddo
9536       return
9537       end
9538 c----------------------------------------------------------------------------
9539       double precision function eello_turn6(i,jj,kk)
9540       implicit real*8 (a-h,o-z)
9541       include 'DIMENSIONS'
9542       include 'COMMON.IOUNITS'
9543       include 'COMMON.CHAIN'
9544       include 'COMMON.DERIV'
9545       include 'COMMON.INTERACT'
9546       include 'COMMON.CONTACTS'
9547       include 'COMMON.TORSION'
9548       include 'COMMON.VAR'
9549       include 'COMMON.GEO'
9550       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9551      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9552      &  ggg1(3),ggg2(3)
9553       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9554      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9555 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9556 C           the respective energy moment and not to the cluster cumulant.
9557       s1=0.0d0
9558       s8=0.0d0
9559       s13=0.0d0
9560 c
9561       eello_turn6=0.0d0
9562       j=i+4
9563       k=i+1
9564       l=i+3
9565       iti=itortyp(itype(i))
9566       itk=itortyp(itype(k))
9567       itk1=itortyp(itype(k+1))
9568       itl=itortyp(itype(l))
9569       itj=itortyp(itype(j))
9570 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9571 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9572 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9573 cd        eello6=0.0d0
9574 cd        return
9575 cd      endif
9576 cd      write (iout,*)
9577 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9578 cd     &   ' and',k,l
9579 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9580       do iii=1,2
9581         do kkk=1,5
9582           do lll=1,3
9583             derx_turn(lll,kkk,iii)=0.0d0
9584           enddo
9585         enddo
9586       enddo
9587 cd      eij=1.0d0
9588 cd      ekl=1.0d0
9589 cd      ekont=1.0d0
9590       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9591 cd      eello6_5=0.0d0
9592 cd      write (2,*) 'eello6_5',eello6_5
9593 #ifdef MOMENT
9594       call transpose2(AEA(1,1,1),auxmat(1,1))
9595       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9596       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9597       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9598 #endif
9599       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9600       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9601       s2 = scalar2(b1(1,itk),vtemp1(1))
9602 #ifdef MOMENT
9603       call transpose2(AEA(1,1,2),atemp(1,1))
9604       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9605       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9606       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9607 #endif
9608       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9609       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9610       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9611 #ifdef MOMENT
9612       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9613       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9614       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9615       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9616       ss13 = scalar2(b1(1,itk),vtemp4(1))
9617       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9618 #endif
9619 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9620 c      s1=0.0d0
9621 c      s2=0.0d0
9622 c      s8=0.0d0
9623 c      s12=0.0d0
9624 c      s13=0.0d0
9625       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9626 C Derivatives in gamma(i+2)
9627       s1d =0.0d0
9628       s8d =0.0d0
9629 #ifdef MOMENT
9630       call transpose2(AEA(1,1,1),auxmatd(1,1))
9631       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9632       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9633       call transpose2(AEAderg(1,1,2),atempd(1,1))
9634       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9635       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9636 #endif
9637       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9638       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9639       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9640 c      s1d=0.0d0
9641 c      s2d=0.0d0
9642 c      s8d=0.0d0
9643 c      s12d=0.0d0
9644 c      s13d=0.0d0
9645       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9646 C Derivatives in gamma(i+3)
9647 #ifdef MOMENT
9648       call transpose2(AEA(1,1,1),auxmatd(1,1))
9649       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9650       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9651       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9652 #endif
9653       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9654       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9655       s2d = scalar2(b1(1,itk),vtemp1d(1))
9656 #ifdef MOMENT
9657       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9658       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9659 #endif
9660       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9661 #ifdef MOMENT
9662       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9663       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9664       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9665 #endif
9666 c      s1d=0.0d0
9667 c      s2d=0.0d0
9668 c      s8d=0.0d0
9669 c      s12d=0.0d0
9670 c      s13d=0.0d0
9671 #ifdef MOMENT
9672       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9673      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9674 #else
9675       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9676      &               -0.5d0*ekont*(s2d+s12d)
9677 #endif
9678 C Derivatives in gamma(i+4)
9679       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9680       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9681       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9682 #ifdef MOMENT
9683       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9684       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9685       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9686 #endif
9687 c      s1d=0.0d0
9688 c      s2d=0.0d0
9689 c      s8d=0.0d0
9690 C      s12d=0.0d0
9691 c      s13d=0.0d0
9692 #ifdef MOMENT
9693       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9694 #else
9695       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9696 #endif
9697 C Derivatives in gamma(i+5)
9698 #ifdef MOMENT
9699       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9700       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9701       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9702 #endif
9703       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9704       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9705       s2d = scalar2(b1(1,itk),vtemp1d(1))
9706 #ifdef MOMENT
9707       call transpose2(AEA(1,1,2),atempd(1,1))
9708       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9709       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9710 #endif
9711       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9712       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9713 #ifdef MOMENT
9714       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9715       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9716       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9717 #endif
9718 c      s1d=0.0d0
9719 c      s2d=0.0d0
9720 c      s8d=0.0d0
9721 c      s12d=0.0d0
9722 c      s13d=0.0d0
9723 #ifdef MOMENT
9724       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9725      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9726 #else
9727       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9728      &               -0.5d0*ekont*(s2d+s12d)
9729 #endif
9730 C Cartesian derivatives
9731       do iii=1,2
9732         do kkk=1,5
9733           do lll=1,3
9734 #ifdef MOMENT
9735             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9736             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9737             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9738 #endif
9739             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9740             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9741      &          vtemp1d(1))
9742             s2d = scalar2(b1(1,itk),vtemp1d(1))
9743 #ifdef MOMENT
9744             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9745             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9746             s8d = -(atempd(1,1)+atempd(2,2))*
9747      &           scalar2(cc(1,1,itl),vtemp2(1))
9748 #endif
9749             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9750      &           auxmatd(1,1))
9751             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9752             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9753 c      s1d=0.0d0
9754 c      s2d=0.0d0
9755 c      s8d=0.0d0
9756 c      s12d=0.0d0
9757 c      s13d=0.0d0
9758 #ifdef MOMENT
9759             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9760      &        - 0.5d0*(s1d+s2d)
9761 #else
9762             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9763      &        - 0.5d0*s2d
9764 #endif
9765 #ifdef MOMENT
9766             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9767      &        - 0.5d0*(s8d+s12d)
9768 #else
9769             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9770      &        - 0.5d0*s12d
9771 #endif
9772           enddo
9773         enddo
9774       enddo
9775 #ifdef MOMENT
9776       do kkk=1,5
9777         do lll=1,3
9778           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9779      &      achuj_tempd(1,1))
9780           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9781           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9782           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9783           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9784           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9785      &      vtemp4d(1))
9786           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9787           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9788           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9789         enddo
9790       enddo
9791 #endif
9792 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9793 cd     &  16*eel_turn6_num
9794 cd      goto 1112
9795       if (j.lt.nres-1) then
9796         j1=j+1
9797         j2=j-1
9798       else
9799         j1=j-1
9800         j2=j-2
9801       endif
9802       if (l.lt.nres-1) then
9803         l1=l+1
9804         l2=l-1
9805       else
9806         l1=l-1
9807         l2=l-2
9808       endif
9809       do ll=1,3
9810 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9811 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9812 cgrad        ghalf=0.5d0*ggg1(ll)
9813 cd        ghalf=0.0d0
9814         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9815         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9816         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9817      &    +ekont*derx_turn(ll,2,1)
9818         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9819         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9820      &    +ekont*derx_turn(ll,4,1)
9821         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9822         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9823         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9824 cgrad        ghalf=0.5d0*ggg2(ll)
9825 cd        ghalf=0.0d0
9826         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9827      &    +ekont*derx_turn(ll,2,2)
9828         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9829         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9830      &    +ekont*derx_turn(ll,4,2)
9831         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9832         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9833         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9834       enddo
9835 cd      goto 1112
9836 cgrad      do m=i+1,j-1
9837 cgrad        do ll=1,3
9838 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9839 cgrad        enddo
9840 cgrad      enddo
9841 cgrad      do m=k+1,l-1
9842 cgrad        do ll=1,3
9843 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9844 cgrad        enddo
9845 cgrad      enddo
9846 cgrad1112  continue
9847 cgrad      do m=i+2,j2
9848 cgrad        do ll=1,3
9849 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9850 cgrad        enddo
9851 cgrad      enddo
9852 cgrad      do m=k+2,l2
9853 cgrad        do ll=1,3
9854 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9855 cgrad        enddo
9856 cgrad      enddo
9857 cd      do iii=1,nres-3
9858 cd        write (2,*) iii,g_corr6_loc(iii)
9859 cd      enddo
9860       eello_turn6=ekont*eel_turn6
9861 cd      write (2,*) 'ekont',ekont
9862 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9863       return
9864       end
9865
9866 C-----------------------------------------------------------------------------
9867       double precision function scalar(u,v)
9868 !DIR$ INLINEALWAYS scalar
9869 #ifndef OSF
9870 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9871 #endif
9872       implicit none
9873       double precision u(3),v(3)
9874 cd      double precision sc
9875 cd      integer i
9876 cd      sc=0.0d0
9877 cd      do i=1,3
9878 cd        sc=sc+u(i)*v(i)
9879 cd      enddo
9880 cd      scalar=sc
9881
9882       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9883       return
9884       end
9885 crc-------------------------------------------------
9886       SUBROUTINE MATVEC2(A1,V1,V2)
9887 !DIR$ INLINEALWAYS MATVEC2
9888 #ifndef OSF
9889 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9890 #endif
9891       implicit real*8 (a-h,o-z)
9892       include 'DIMENSIONS'
9893       DIMENSION A1(2,2),V1(2),V2(2)
9894 c      DO 1 I=1,2
9895 c        VI=0.0
9896 c        DO 3 K=1,2
9897 c    3     VI=VI+A1(I,K)*V1(K)
9898 c        Vaux(I)=VI
9899 c    1 CONTINUE
9900
9901       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9902       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9903
9904       v2(1)=vaux1
9905       v2(2)=vaux2
9906       END
9907 C---------------------------------------
9908       SUBROUTINE MATMAT2(A1,A2,A3)
9909 #ifndef OSF
9910 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9911 #endif
9912       implicit real*8 (a-h,o-z)
9913       include 'DIMENSIONS'
9914       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9915 c      DIMENSION AI3(2,2)
9916 c        DO  J=1,2
9917 c          A3IJ=0.0
9918 c          DO K=1,2
9919 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9920 c          enddo
9921 c          A3(I,J)=A3IJ
9922 c       enddo
9923 c      enddo
9924
9925       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9926       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9927       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9928       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9929
9930       A3(1,1)=AI3_11
9931       A3(2,1)=AI3_21
9932       A3(1,2)=AI3_12
9933       A3(2,2)=AI3_22
9934       END
9935
9936 c-------------------------------------------------------------------------
9937       double precision function scalar2(u,v)
9938 !DIR$ INLINEALWAYS scalar2
9939       implicit none
9940       double precision u(2),v(2)
9941       double precision sc
9942       integer i
9943       scalar2=u(1)*v(1)+u(2)*v(2)
9944       return
9945       end
9946
9947 C-----------------------------------------------------------------------------
9948
9949       subroutine transpose2(a,at)
9950 !DIR$ INLINEALWAYS transpose2
9951 #ifndef OSF
9952 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9953 #endif
9954       implicit none
9955       double precision a(2,2),at(2,2)
9956       at(1,1)=a(1,1)
9957       at(1,2)=a(2,1)
9958       at(2,1)=a(1,2)
9959       at(2,2)=a(2,2)
9960       return
9961       end
9962 c--------------------------------------------------------------------------
9963       subroutine transpose(n,a,at)
9964       implicit none
9965       integer n,i,j
9966       double precision a(n,n),at(n,n)
9967       do i=1,n
9968         do j=1,n
9969           at(j,i)=a(i,j)
9970         enddo
9971       enddo
9972       return
9973       end
9974 C---------------------------------------------------------------------------
9975       subroutine prodmat3(a1,a2,kk,transp,prod)
9976 !DIR$ INLINEALWAYS prodmat3
9977 #ifndef OSF
9978 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9979 #endif
9980       implicit none
9981       integer i,j
9982       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9983       logical transp
9984 crc      double precision auxmat(2,2),prod_(2,2)
9985
9986       if (transp) then
9987 crc        call transpose2(kk(1,1),auxmat(1,1))
9988 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9989 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9990
9991            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9992      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9993            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9994      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9995            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9996      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9997            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9998      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9999
10000       else
10001 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10002 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10003
10004            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10005      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10006            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10007      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10008            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10009      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10010            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10011      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10012
10013       endif
10014 c      call transpose2(a2(1,1),a2t(1,1))
10015
10016 crc      print *,transp
10017 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10018 crc      print *,((prod(i,j),i=1,2),j=1,2)
10019
10020       return
10021       end
10022