source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       call flush(iout)
  31       if (nfgtasks.gt.1) then
  32 #ifdef MPI
  33         time00=MPI_Wtime()
  34 #else
  35         time00=tcpu()
  36 #endif
  37 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  38         if (fg_rank.eq.0) then
  39           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  40 c          print *,"Processor",myrank," BROADCAST iorder"
  41 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  42 C FG slaves as WEIGHTS array.
  43           weights_(1)=wsc
  44           weights_(2)=wscp
  45           weights_(3)=welec
  46           weights_(4)=wcorr
  47           weights_(5)=wcorr5
  48           weights_(6)=wcorr6
  49           weights_(7)=wel_loc
  50           weights_(8)=wturn3
  51           weights_(9)=wturn4
  52           weights_(10)=wturn6
  53           weights_(11)=wang
  54           weights_(12)=wscloc
  55           weights_(13)=wtor
  56           weights_(14)=wtor_d
  57           weights_(15)=wstrain
  58           weights_(16)=wvdwpp
  59           weights_(17)=wbond
  60           weights_(18)=scal14
  61           weights_(21)=wsccor
  62           weights_(22)=wsct
  63 C FG Master broadcasts the WEIGHTS_ array
  64           call MPI_Bcast(weights_(1),n_ene,
  65      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  66         else
  67 C FG slaves receive the WEIGHTS array
  68           call MPI_Bcast(weights(1),n_ene,
  69      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  70           wsc=weights(1)
  71           wscp=weights(2)
  72           welec=weights(3)
  73           wcorr=weights(4)
  74           wcorr5=weights(5)
  75           wcorr6=weights(6)
  76           wel_loc=weights(7)
  77           wturn3=weights(8)
  78           wturn4=weights(9)
  79           wturn6=weights(10)
  80           wang=weights(11)
  81           wscloc=weights(12)
  82           wtor=weights(13)
  83           wtor_d=weights(14)
  84           wstrain=weights(15)
  85           wvdwpp=weights(16)
  86           wbond=weights(17)
  87           scal14=weights(18)
  88           wsccor=weights(21)
  89           wsct=weights(22)
  90         endif
  91         time_Bcast=time_Bcast+MPI_Wtime()-time00
  92         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  93 c        call chainbuild_cart
  94       endif
  95 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  96 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  97 #else
  98 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  99 c        call int_from_cart1(.false.)
 100 c      endif
 101 #endif
 102 #ifdef TIMING
 103 #ifdef MPI
 104       time00=MPI_Wtime()
 105 #else
 106       time00=tcpu()
 107 #endif
 108 #endif
 109 C
 110 C Compute the side-chain and electrostatic interaction energy
 111 C
 112       goto (101,102,103,104,105,106) ipot
 113 C Lennard-Jones potential.
 114   101 call elj(evdw,evdw_p,evdw_m)
 115 cd    print '(a)','Exit ELJ'
 116       goto 107
 117 C Lennard-Jones-Kihara potential (shifted).
 118   102 call eljk(evdw,evdw_p,evdw_m)
 119       goto 107
 120 C Berne-Pechukas potential (dilated LJ, angular dependence).
 121   103 call ebp(evdw,evdw_p,evdw_m)
 122       goto 107
 123 C Gay-Berne potential (shifted LJ, angular dependence).
 124   104 call egb(evdw,evdw_p,evdw_m)
 125       goto 107
 126 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 127   105 call egbv(evdw,evdw_p,evdw_m)
 128       goto 107
 129 C Soft-sphere potential
 130   106 call e_softsphere(evdw)
 131 C
 132 C Calculate electrostatic (H-bonding) energy of the main chain.
 133 C
 134   107 continue
 135 C     BARTEK for dfa test!
 136       if (wdfa_dist.gt.0) then
 137         call edfad(edfadis)
 138       else
 139         edfadis=0
 140       endif
 141 c      print*, 'edfad is finished!', edfadis
 142       if (wdfa_tor.gt.0) then
 143         call edfat(edfator)
 144       else
 145         edfator=0
 146       endif
 147 c      print*, 'edfat is finished!', edfator
 148       if (wdfa_nei.gt.0) then
 149         call edfan(edfanei)
 150       else
 151         edfanei=0
 152       endif
 153 c      print*, 'edfan is finished!', edfanei
 154       if (wdfa_beta.gt.0) then
 155         call edfab(edfabet)
 156       else
 157         edfabet=0
 158       endif
 159 c      print*, 'edfab is finished!', edfabet
 160 cmc
 161 cmc Sep-06: egb takes care of dynamic ss bonds too
 162 cmc
 163 c      if (dyn_ss) call dyn_set_nss
 164
 165 c      print *,"Processor",myrank," computed USCSC"
 166 #ifdef TIMING
 167 #ifdef MPI
 168       time01=MPI_Wtime()
 169 #else
 170       time00=tcpu()
 171 #endif
 172 #endif
 173       call vec_and_deriv
 174 #ifdef TIMING
 175 #ifdef MPI
 176       time_vec=time_vec+MPI_Wtime()-time01
 177 #else
 178       time_vec=time_vec+tcpu()-time01
 179 #endif
 180 #endif
 181 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 182       if (ipot.lt.6) then
 183 #ifdef SPLITELE
 184          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 185      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 186      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 187      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 188 #else
 189          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 190      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 191      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 192      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 193 #endif
 194             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 195          else
 196             ees=0.0d0
 197             evdw1=0.0d0
 198             eel_loc=0.0d0
 199             eello_turn3=0.0d0
 200             eello_turn4=0.0d0
 201          endif
 202       else
 203 c        write (iout,*) "Soft-spheer ELEC potential"
 204         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 205      &   eello_turn4)
 206       endif
 207 c      print *,"Processor",myrank," computed UELEC"
 208 C
 209 C Calculate excluded-volume interaction energy between peptide groups
 210 C and side chains.
 211 C
 212       if (ipot.lt.6) then
 213        if(wscp.gt.0d0) then
 214         call escp(evdw2,evdw2_14)
 215        else
 216         evdw2=0
 217         evdw2_14=0
 218        endif
 219       else
 220 c        write (iout,*) "Soft-sphere SCP potential"
 221         call escp_soft_sphere(evdw2,evdw2_14)
 222       endif
 223 c
 224 c Calculate the bond-stretching energy
 225 c
 226       call ebond(estr)
 227 C
 228 C Calculate the disulfide-bridge and other energy and the contributions
 229 C from other distance constraints.
 230 cd    print *,'Calling EHPB'
 231       call edis(ehpb)
 232 cd    print *,'EHPB exitted succesfully.'
 233 C
 234 C Calculate the virtual-bond-angle energy.
 235 C
 236       if (wang.gt.0d0) then
 237         call ebend(ebe)
 238       else
 239         ebe=0
 240       endif
 241 c      print *,"Processor",myrank," computed UB"
 242 C
 243 C Calculate the SC local energy.
 244 C
 245       call esc(escloc)
 246 c      print *,"Processor",myrank," computed USC"
 247 C
 248 C Calculate the virtual-bond torsional energy.
 249 C
 250 cd    print *,'nterm=',nterm
 251       if (wtor.gt.0) then
 252        call etor(etors,edihcnstr)
 253       else
 254        etors=0
 255        edihcnstr=0
 256       endif
 257
 258       if (constr_homology.ge.1) then
 259         call e_modeller(ehomology_constr)
 260         print *,'iset=',iset,'me=',me,ehomology_constr,
 261      &  'Processor',fg_rank,' CG group',kolor,
 262      &  ' absolute rank',MyRank
 263       else
 264         ehomology_constr=0.0d0
 265       endif
 266
 267
 268 c      write(iout,*) ehomology_constr
 269 c      print *,"Processor",myrank," computed Utor"
 270 C
 271 C 6/23/01 Calculate double-torsional energy
 272 C
 273       if (wtor_d.gt.0) then
 274        call etor_d(etors_d)
 275       else
 276        etors_d=0
 277       endif
 278 c      print *,"Processor",myrank," computed Utord"
 279 C
 280 C 21/5/07 Calculate local sicdechain correlation energy
 281 C
 282       if (wsccor.gt.0.0d0) then
 283         call eback_sc_corr(esccor)
 284       else
 285         esccor=0.0d0
 286       endif
 287 c      print *,"Processor",myrank," computed Usccorr"
 288 C
 289 C 12/1/95 Multi-body terms
 290 C
 291       n_corr=0
 292       n_corr1=0
 293       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 294      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 295          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 296 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 297 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 298       else
 299          ecorr=0.0d0
 300          ecorr5=0.0d0
 301          ecorr6=0.0d0
 302          eturn6=0.0d0
 303       endif
 304       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 305          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 306 cd         write (iout,*) "multibody_hb ecorr",ecorr
 307       endif
 308 c      print *,"Processor",myrank," computed Ucorr"
 309 C
 310 C If performing constraint dynamics, call the constraint energy
 311 C  after the equilibration time
 312       if(usampl.and.totT.gt.eq_time) then
 313          call EconstrQ
 314          call Econstr_back
 315       else
 316          Uconst=0.0d0
 317          Uconst_back=0.0d0
 318       endif
 319 #ifdef TIMING
 320 #ifdef MPI
 321       time_enecalc=time_enecalc+MPI_Wtime()-time00
 322 #else
 323       time_enecalc=time_enecalc+tcpu()-time00
 324 #endif
 325 #endif
 326 c      print *,"Processor",myrank," computed Uconstr"
 327 #ifdef TIMING
 328 #ifdef MPI
 329       time00=MPI_Wtime()
 330 #else
 331       time00=tcpu()
 332 #endif
 333 #endif
 334 c
 335 C Sum the energies
 336 C
 337       energia(1)=evdw
 338 #ifdef SCP14
 339       energia(2)=evdw2-evdw2_14
 340       energia(18)=evdw2_14
 341 #else
 342       energia(2)=evdw2
 343       energia(18)=0.0d0
 344 #endif
 345 #ifdef SPLITELE
 346       energia(3)=ees
 347       energia(16)=evdw1
 348 #else
 349       energia(3)=ees+evdw1
 350       energia(16)=0.0d0
 351 #endif
 352       energia(4)=ecorr
 353       energia(5)=ecorr5
 354       energia(6)=ecorr6
 355       energia(7)=eel_loc
 356       energia(8)=eello_turn3
 357       energia(9)=eello_turn4
 358       energia(10)=eturn6
 359       energia(11)=ebe
 360       energia(12)=escloc
 361       energia(13)=etors
 362       energia(14)=etors_d
 363       energia(15)=ehpb
 364       energia(19)=edihcnstr
 365       energia(17)=estr
 366       energia(20)=Uconst+Uconst_back
 367       energia(21)=esccor
 368       energia(22)=evdw_p
 369       energia(23)=evdw_m
 370       energia(24)=ehomology_constr
 371       energia(25)=edfadis
 372       energia(26)=edfator
 373       energia(27)=edfanei
 374       energia(28)=edfabet
 375 c      print *," Processor",myrank," calls SUM_ENERGY"
 376       call sum_energy(energia,.true.)
 377       if (dyn_ss) call dyn_set_nss
 378 c      print *," Processor",myrank," left SUM_ENERGY"
 379 #ifdef TIMING
 380 #ifdef MPI
 381       time_sumene=time_sumene+MPI_Wtime()-time00
 382 #else
 383       time_sumene=time_sumene+tcpu()-time00
 384 #endif
 385 #endif
 386       return
 387       end
 388 c-------------------------------------------------------------------------------
 389       subroutine sum_energy(energia,reduce)
 390       implicit real*8 (a-h,o-z)
 391       include 'DIMENSIONS'
 392 #ifndef ISNAN
 393       external proc_proc
 394 #ifdef WINPGI
 395 cMS$ATTRIBUTES C ::  proc_proc
 396 #endif
 397 #endif
 398 #ifdef MPI
 399       include "mpif.h"
 400 #endif
 401       include 'COMMON.SETUP'
 402       include 'COMMON.IOUNITS'
 403       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 404       include 'COMMON.FFIELD'
 405       include 'COMMON.DERIV'
 406       include 'COMMON.INTERACT'
 407       include 'COMMON.SBRIDGE'
 408       include 'COMMON.CHAIN'
 409       include 'COMMON.VAR'
 410       include 'COMMON.CONTROL'
 411       include 'COMMON.TIME1'
 412       logical reduce
 413 #ifdef MPI
 414       if (nfgtasks.gt.1 .and. reduce) then
 415 #ifdef DEBUG
 416         write (iout,*) "energies before REDUCE"
 417         call enerprint(energia)
 418         call flush(iout)
 419 #endif
 420         do i=0,n_ene
 421           enebuff(i)=energia(i)
 422         enddo
 423         time00=MPI_Wtime()
 424         call MPI_Barrier(FG_COMM,IERR)
 425         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 426         time00=MPI_Wtime()
 427         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 428      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 429 #ifdef DEBUG
 430         write (iout,*) "energies after REDUCE"
 431         call enerprint(energia)
 432         call flush(iout)
 433 #endif
 434         time_Reduce=time_Reduce+MPI_Wtime()-time00
 435       endif
 436       if (fg_rank.eq.0) then
 437 #endif
 438 #ifdef TSCSC
 439       evdw=energia(22)+wsct*energia(23)
 440 #else
 441       evdw=energia(1)
 442 #endif
 443 #ifdef SCP14
 444       evdw2=energia(2)+energia(18)
 445       evdw2_14=energia(18)
 446 #else
 447       evdw2=energia(2)
 448 #endif
 449 #ifdef SPLITELE
 450       ees=energia(3)
 451       evdw1=energia(16)
 452 #else
 453       ees=energia(3)
 454       evdw1=0.0d0
 455 #endif
 456       ecorr=energia(4)
 457       ecorr5=energia(5)
 458       ecorr6=energia(6)
 459       eel_loc=energia(7)
 460       eello_turn3=energia(8)
 461       eello_turn4=energia(9)
 462       eturn6=energia(10)
 463       ebe=energia(11)
 464       escloc=energia(12)
 465       etors=energia(13)
 466       etors_d=energia(14)
 467       ehpb=energia(15)
 468       edihcnstr=energia(19)
 469       estr=energia(17)
 470       Uconst=energia(20)
 471       esccor=energia(21)
 472       ehomology_constr=energia(24)
 473       edfadis=energia(25)
 474       edfator=energia(26)
 475       edfanei=energia(27)
 476       edfabet=energia(28)
 477 #ifdef SPLITELE
 478       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 479      & +wang*ebe+wtor*etors+wscloc*escloc
 480      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 481      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 482      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 483      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 484      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 485      & +wdfa_beta*edfabet
 486 #else
 487       etot=wsc*evdw+wscp*evdw2+welec*(ees+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 #endif
 496       energia(0)=etot
 497 c detecting NaNQ
 498 #ifdef ISNAN
 499 #ifdef AIX
 500       if (isnan(etot).ne.0) energia(0)=1.0d+99
 501 #else
 502       if (isnan(etot)) energia(0)=1.0d+99
 503 #endif
 504 #else
 505       i=0
 506 #ifdef WINPGI
 507       idumm=proc_proc(etot,i)
 508 #else
 509       call proc_proc(etot,i)
 510 #endif
 511       if(i.eq.1)energia(0)=1.0d+99
 512 #endif
 513 #ifdef MPI
 514       endif
 515 #endif
 516       return
 517       end
 518 c-------------------------------------------------------------------------------
 519       subroutine sum_gradient
 520       implicit real*8 (a-h,o-z)
 521       include 'DIMENSIONS'
 522 #ifndef ISNAN
 523       external proc_proc
 524 #ifdef WINPGI
 525 cMS$ATTRIBUTES C ::  proc_proc
 526 #endif
 527 #endif
 528 #ifdef MPI
 529       include 'mpif.h'
 530 #endif
 531       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 532      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 533       include 'COMMON.SETUP'
 534       include 'COMMON.IOUNITS'
 535       include 'COMMON.FFIELD'
 536       include 'COMMON.DERIV'
 537       include 'COMMON.INTERACT'
 538       include 'COMMON.SBRIDGE'
 539       include 'COMMON.CHAIN'
 540       include 'COMMON.VAR'
 541       include 'COMMON.CONTROL'
 542       include 'COMMON.TIME1'
 543       include 'COMMON.MAXGRAD'
 544       include 'COMMON.SCCOR'
 545 #ifdef TIMING
 546 #ifdef MPI
 547       time01=MPI_Wtime()
 548 #else
 549       time01=tcpu()
 550 #endif
 551 #endif
 552 #ifdef DEBUG
 553       write (iout,*) "sum_gradient gvdwc, gvdwx"
 554       do i=1,nres
 555         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 556      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 557      &   (gvdwcT(j,i),j=1,3)
 558       enddo
 559       call flush(iout)
 560 #endif
 561 #ifdef MPI
 562 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 563         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 564      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 565 #endif
 566 C
 567 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 568 C            in virtual-bond-vector coordinates
 569 C
 570 #ifdef DEBUG
 571 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 572 c      do i=1,nres-1
 573 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 574 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 575 c      enddo
 576 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 577 c      do i=1,nres-1
 578 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 579 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 580 c      enddo
 581       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 584      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 585      &   g_corr5_loc(i)
 586       enddo
 587       call flush(iout)
 588 #endif
 589 #ifdef SPLITELE
 590 #ifdef TSCSC
 591       do i=1,nct
 592         do j=1,3
 593           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 594      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 595      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 596      &                wel_loc*gel_loc_long(j,i)+
 597      &                wcorr*gradcorr_long(j,i)+
 598      &                wcorr5*gradcorr5_long(j,i)+
 599      &                wcorr6*gradcorr6_long(j,i)+
 600      &                wturn6*gcorr6_turn_long(j,i)+
 601      &                wstrain*ghpbc(j,i)+
 602      &                wdfa_dist*gdfad(j,i)+
 603      &                wdfa_tor*gdfat(j,i)+
 604      &                wdfa_nei*gdfan(j,i)+
 605      &                wdfa_beta*gdfab(j,i)
 606         enddo
 607       enddo
 608 #else
 609       do i=1,nct
 610         do j=1,3
 611           gradbufc(j,i)=wsc*gvdwc(j,i)+
 612      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 613      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 614      &                wel_loc*gel_loc_long(j,i)+
 615      &                wcorr*gradcorr_long(j,i)+
 616      &                wcorr5*gradcorr5_long(j,i)+
 617      &                wcorr6*gradcorr6_long(j,i)+
 618      &                wturn6*gcorr6_turn_long(j,i)+
 619      &                wstrain*ghpbc(j,i)+
 620      &                wdfa_dist*gdfad(j,i)+
 621      &                wdfa_tor*gdfat(j,i)+
 622      &                wdfa_nei*gdfan(j,i)+
 623      &                wdfa_beta*gdfab(j,i)
 624         enddo
 625       enddo
 626 #endif
 627 #else
 628       do i=1,nct
 629         do j=1,3
 630           gradbufc(j,i)=wsc*gvdwc(j,i)+
 631      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 632      &                welec*gelc_long(j,i)+
 633      &                wbond*gradb(j,i)+
 634      &                wel_loc*gel_loc_long(j,i)+
 635      &                wcorr*gradcorr_long(j,i)+
 636      &                wcorr5*gradcorr5_long(j,i)+
 637      &                wcorr6*gradcorr6_long(j,i)+
 638      &                wturn6*gcorr6_turn_long(j,i)+
 639      &                wstrain*ghpbc(j,i)+
 640      &                wdfa_dist*gdfad(j,i)+
 641      &                wdfa_tor*gdfat(j,i)+
 642      &                wdfa_nei*gdfan(j,i)+
 643      &                wdfa_beta*gdfab(j,i)
 644         enddo
 645       enddo
 646 #endif
 647 #ifdef MPI
 648       if (nfgtasks.gt.1) then
 649       time00=MPI_Wtime()
 650 #ifdef DEBUG
 651       write (iout,*) "gradbufc before allreduce"
 652       do i=1,nres
 653         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 654       enddo
 655       call flush(iout)
 656 #endif
 657       do i=1,nres
 658         do j=1,3
 659           gradbufc_sum(j,i)=gradbufc(j,i)
 660         enddo
 661       enddo
 662 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 663 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 664 c      time_reduce=time_reduce+MPI_Wtime()-time00
 665 #ifdef DEBUG
 666 c      write (iout,*) "gradbufc_sum after allreduce"
 667 c      do i=1,nres
 668 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 669 c      enddo
 670 c      call flush(iout)
 671 #endif
 672 #ifdef TIMING
 673 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 674 #endif
 675       do i=nnt,nres
 676         do k=1,3
 677           gradbufc(k,i)=0.0d0
 678         enddo
 679       enddo
 680 #ifdef DEBUG
 681       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 682       write (iout,*) (i," jgrad_start",jgrad_start(i),
 683      &                  " jgrad_end  ",jgrad_end(i),
 684      &                  i=igrad_start,igrad_end)
 685 #endif
 686 c
 687 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 688 c do not parallelize this part.
 689 c
 690 c      do i=igrad_start,igrad_end
 691 c        do j=jgrad_start(i),jgrad_end(i)
 692 c          do k=1,3
 693 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 694 c          enddo
 695 c        enddo
 696 c      enddo
 697       do j=1,3
 698         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 699       enddo
 700       do i=nres-2,nnt,-1
 701         do j=1,3
 702           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 703         enddo
 704       enddo
 705 #ifdef DEBUG
 706       write (iout,*) "gradbufc after summing"
 707       do i=1,nres
 708         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 709       enddo
 710       call flush(iout)
 711 #endif
 712       else
 713 #endif
 714 #ifdef DEBUG
 715       write (iout,*) "gradbufc"
 716       do i=1,nres
 717         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 718       enddo
 719       call flush(iout)
 720 #endif
 721       do i=1,nres
 722         do j=1,3
 723           gradbufc_sum(j,i)=gradbufc(j,i)
 724           gradbufc(j,i)=0.0d0
 725         enddo
 726       enddo
 727       do j=1,3
 728         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 729       enddo
 730       do i=nres-2,nnt,-1
 731         do j=1,3
 732           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 733         enddo
 734       enddo
 735 c      do i=nnt,nres-1
 736 c        do k=1,3
 737 c          gradbufc(k,i)=0.0d0
 738 c        enddo
 739 c        do j=i+1,nres
 740 c          do k=1,3
 741 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 742 c          enddo
 743 c        enddo
 744 c      enddo
 745 #ifdef DEBUG
 746       write (iout,*) "gradbufc after summing"
 747       do i=1,nres
 748         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 749       enddo
 750       call flush(iout)
 751 #endif
 752 #ifdef MPI
 753       endif
 754 #endif
 755       do k=1,3
 756         gradbufc(k,nres)=0.0d0
 757       enddo
 758       do i=1,nct
 759         do j=1,3
 760 #ifdef SPLITELE
 761           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 762      &                wel_loc*gel_loc(j,i)+
 763      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 764      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 765      &                wel_loc*gel_loc_long(j,i)+
 766      &                wcorr*gradcorr_long(j,i)+
 767      &                wcorr5*gradcorr5_long(j,i)+
 768      &                wcorr6*gradcorr6_long(j,i)+
 769      &                wturn6*gcorr6_turn_long(j,i))+
 770      &                wbond*gradb(j,i)+
 771      &                wcorr*gradcorr(j,i)+
 772      &                wturn3*gcorr3_turn(j,i)+
 773      &                wturn4*gcorr4_turn(j,i)+
 774      &                wcorr5*gradcorr5(j,i)+
 775      &                wcorr6*gradcorr6(j,i)+
 776      &                wturn6*gcorr6_turn(j,i)+
 777      &                wsccor*gsccorc(j,i)
 778      &               +wscloc*gscloc(j,i)
 779 #else
 780           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 781      &                wel_loc*gel_loc(j,i)+
 782      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 783      &                welec*gelc_long(j,i)+
 784      &                wel_loc*gel_loc_long(j,i)+
 785      &                wcorr*gcorr_long(j,i)+
 786      &                wcorr5*gradcorr5_long(j,i)+
 787      &                wcorr6*gradcorr6_long(j,i)+
 788      &                wturn6*gcorr6_turn_long(j,i))+
 789      &                wbond*gradb(j,i)+
 790      &                wcorr*gradcorr(j,i)+
 791      &                wturn3*gcorr3_turn(j,i)+
 792      &                wturn4*gcorr4_turn(j,i)+
 793      &                wcorr5*gradcorr5(j,i)+
 794      &                wcorr6*gradcorr6(j,i)+
 795      &                wturn6*gcorr6_turn(j,i)+
 796      &                wsccor*gsccorc(j,i)
 797      &               +wscloc*gscloc(j,i)
 798 #endif
 799 #ifdef TSCSC
 800           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 801      &                  wscp*gradx_scp(j,i)+
 802      &                  wbond*gradbx(j,i)+
 803      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 804      &                  wsccor*gsccorx(j,i)
 805      &                 +wscloc*gsclocx(j,i)
 806 #else
 807           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 808      &                  wbond*gradbx(j,i)+
 809      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 810      &                  wsccor*gsccorx(j,i)
 811      &                 +wscloc*gsclocx(j,i)
 812 #endif
 813         enddo
 814       enddo
 815 #ifdef DEBUG
 816       write (iout,*) "gloc before adding corr"
 817       do i=1,4*nres
 818         write (iout,*) i,gloc(i,icg)
 819       enddo
 820 #endif
 821       do i=1,nres-3
 822         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 823      &   +wcorr5*g_corr5_loc(i)
 824      &   +wcorr6*g_corr6_loc(i)
 825      &   +wturn4*gel_loc_turn4(i)
 826      &   +wturn3*gel_loc_turn3(i)
 827      &   +wturn6*gel_loc_turn6(i)
 828      &   +wel_loc*gel_loc_loc(i)
 829       enddo
 830 #ifdef DEBUG
 831       write (iout,*) "gloc after adding corr"
 832       do i=1,4*nres
 833         write (iout,*) i,gloc(i,icg)
 834       enddo
 835 #endif
 836 #ifdef MPI
 837       if (nfgtasks.gt.1) then
 838         do j=1,3
 839           do i=1,nres
 840             gradbufc(j,i)=gradc(j,i,icg)
 841             gradbufx(j,i)=gradx(j,i,icg)
 842           enddo
 843         enddo
 844         do i=1,4*nres
 845           glocbuf(i)=gloc(i,icg)
 846         enddo
 847 #ifdef DEBUG
 848       write (iout,*) "gloc_sc before reduce"
 849       do i=1,nres
 850        do j=1,3
 851         write (iout,*) i,j,gloc_sc(j,i,icg)
 852        enddo
 853       enddo
 854 #endif
 855         do i=1,nres
 856          do j=1,3
 857           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 858          enddo
 859         enddo
 860         time00=MPI_Wtime()
 861         call MPI_Barrier(FG_COMM,IERR)
 862         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 863         time00=MPI_Wtime()
 864         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 865      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 866         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 867      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 868         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 869      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 870         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 871      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 872         time_reduce=time_reduce+MPI_Wtime()-time00
 873 #ifdef DEBUG
 874       write (iout,*) "gloc_sc after reduce"
 875       do i=1,nres
 876        do j=1,3
 877         write (iout,*) i,j,gloc_sc(j,i,icg)
 878        enddo
 879       enddo
 880 #endif
 881 #ifdef DEBUG
 882       write (iout,*) "gloc after reduce"
 883       do i=1,4*nres
 884         write (iout,*) i,gloc(i,icg)
 885       enddo
 886 #endif
 887       endif
 888 #endif
 889       if (gnorm_check) then
 890 c
 891 c Compute the maximum elements of the gradient
 892 c
 893       gvdwc_max=0.0d0
 894       gvdwc_scp_max=0.0d0
 895       gelc_max=0.0d0
 896       gvdwpp_max=0.0d0
 897       gradb_max=0.0d0
 898       ghpbc_max=0.0d0
 899       gradcorr_max=0.0d0
 900       gel_loc_max=0.0d0
 901       gcorr3_turn_max=0.0d0
 902       gcorr4_turn_max=0.0d0
 903       gradcorr5_max=0.0d0
 904       gradcorr6_max=0.0d0
 905       gcorr6_turn_max=0.0d0
 906       gsccorc_max=0.0d0
 907       gscloc_max=0.0d0
 908       gvdwx_max=0.0d0
 909       gradx_scp_max=0.0d0
 910       ghpbx_max=0.0d0
 911       gradxorr_max=0.0d0
 912       gsccorx_max=0.0d0
 913       gsclocx_max=0.0d0
 914       do i=1,nct
 915         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 916         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 917 #ifdef TSCSC
 918         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 919         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 920 #endif
 921         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 922         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 923      &   gvdwc_scp_max=gvdwc_scp_norm
 924         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 925         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 926         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 927         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 928         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 929         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 930         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 931         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 932         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 933         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 934         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 935         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 936         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 937      &    gcorr3_turn(1,i)))
 938         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 939      &    gcorr3_turn_max=gcorr3_turn_norm
 940         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 941      &    gcorr4_turn(1,i)))
 942         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 943      &    gcorr4_turn_max=gcorr4_turn_norm
 944         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 945         if (gradcorr5_norm.gt.gradcorr5_max)
 946      &    gradcorr5_max=gradcorr5_norm
 947         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 948         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 949         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 950      &    gcorr6_turn(1,i)))
 951         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 952      &    gcorr6_turn_max=gcorr6_turn_norm
 953         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 954         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 955         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 956         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 957         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 958         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 959 #ifdef TSCSC
 960         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 961         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 962 #endif
 963         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 964         if (gradx_scp_norm.gt.gradx_scp_max)
 965      &    gradx_scp_max=gradx_scp_norm
 966         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 967         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 968         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 969         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 970         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 971         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 972         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 973         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 974       enddo
 975       if (gradout) then
 976 #ifdef AIX
 977         open(istat,file=statname,position="append")
 978 #else
 979         open(istat,file=statname,access="append")
 980 #endif
 981         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 982      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 983      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 984      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 985      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 986      &     gsccorx_max,gsclocx_max
 987         close(istat)
 988         if (gvdwc_max.gt.1.0d4) then
 989           write (iout,*) "gvdwc gvdwx gradb gradbx"
 990           do i=nnt,nct
 991             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 992      &        gradb(j,i),gradbx(j,i),j=1,3)
 993           enddo
 994           call pdbout(0.0d0,'cipiszcze',iout)
 995           call flush(iout)
 996         endif
 997       endif
 998       endif
 999 #ifdef DEBUG
1000       write (iout,*) "gradc gradx gloc"
1001       do i=1,nres
1002         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1003      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1004       enddo
1005 #endif
1006 #ifdef TIMING
1007 #ifdef MPI
1008       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1009 #else
1010       time_sumgradient=time_sumgradient+tcpu()-time01
1011 #endif
1012 #endif
1013       return
1014       end
1015 c-------------------------------------------------------------------------------
1016       subroutine rescale_weights(t_bath)
1017       implicit real*8 (a-h,o-z)
1018       include 'DIMENSIONS'
1019       include 'COMMON.IOUNITS'
1020       include 'COMMON.FFIELD'
1021       include 'COMMON.SBRIDGE'
1022       double precision kfac /2.4d0/
1023       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1024 c      facT=temp0/t_bath
1025 c      facT=2*temp0/(t_bath+temp0)
1026       if (rescale_mode.eq.0) then
1027         facT=1.0d0
1028         facT2=1.0d0
1029         facT3=1.0d0
1030         facT4=1.0d0
1031         facT5=1.0d0
1032       else if (rescale_mode.eq.1) then
1033         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1034         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1035         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1036         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1037         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1038       else if (rescale_mode.eq.2) then
1039         x=t_bath/temp0
1040         x2=x*x
1041         x3=x2*x
1042         x4=x3*x
1043         x5=x4*x
1044         facT=licznik/dlog(dexp(x)+dexp(-x))
1045         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1046         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1047         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1048         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1049       else
1050         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1051         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1052 #ifdef MPI
1053        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1054 #endif
1055        stop 555
1056       endif
1057       welec=weights(3)*fact
1058       wcorr=weights(4)*fact3
1059       wcorr5=weights(5)*fact4
1060       wcorr6=weights(6)*fact5
1061       wel_loc=weights(7)*fact2
1062       wturn3=weights(8)*fact2
1063       wturn4=weights(9)*fact3
1064       wturn6=weights(10)*fact5
1065       wtor=weights(13)*fact
1066       wtor_d=weights(14)*fact2
1067       wsccor=weights(21)*fact
1068 #ifdef TSCSC
1069 c      wsct=t_bath/temp0
1070       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1071 #endif
1072       return
1073       end
1074 C------------------------------------------------------------------------
1075       subroutine enerprint(energia)
1076       implicit real*8 (a-h,o-z)
1077       include 'DIMENSIONS'
1078       include 'COMMON.IOUNITS'
1079       include 'COMMON.FFIELD'
1080       include 'COMMON.SBRIDGE'
1081       include 'COMMON.MD'
1082       double precision energia(0:n_ene)
1083       etot=energia(0)
1084 #ifdef TSCSC
1085       evdw=energia(22)+wsct*energia(23)
1086 #else
1087       evdw=energia(1)
1088 #endif
1089       evdw2=energia(2)
1090 #ifdef SCP14
1091       evdw2=energia(2)+energia(18)
1092 #else
1093       evdw2=energia(2)
1094 #endif
1095       ees=energia(3)
1096 #ifdef SPLITELE
1097       evdw1=energia(16)
1098 #endif
1099       ecorr=energia(4)
1100       ecorr5=energia(5)
1101       ecorr6=energia(6)
1102       eel_loc=energia(7)
1103       eello_turn3=energia(8)
1104       eello_turn4=energia(9)
1105       eello_turn6=energia(10)
1106       ebe=energia(11)
1107       escloc=energia(12)
1108       etors=energia(13)
1109       etors_d=energia(14)
1110       ehpb=energia(15)
1111       edihcnstr=energia(19)
1112       estr=energia(17)
1113       Uconst=energia(20)
1114       esccor=energia(21)
1115       ehomology_constr=energia(24)
1116 C     Bartek
1117       edfadis = energia(25)
1118       edfator = energia(26)
1119       edfanei = energia(27)
1120       edfabet = energia(28)
1121
1122 #ifdef SPLITELE
1123       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1124      &  estr,wbond,ebe,wang,
1125      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1126      &  ecorr,wcorr,
1127      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1128      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1129      &  edihcnstr,ehomology_constr, ebr*nss,
1130      &  Uconst,edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1131      &  edfabet,wdfa_beta,etot
1132    10 format (/'Virtual-chain energies:'//
1133      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1134      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1135      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1136      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1137      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1138      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1139      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1140      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1141      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1142      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1143      & ' (SS bridges & dist. cnstr.)'/
1144      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1145      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1146      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1147      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1148      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1149      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1150      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1151      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1152      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1153      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1154      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1155      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1156      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1157      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1158      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1159      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1160      & 'ETOT=  ',1pE16.6,' (total)')
1161 #else
1162       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1163      &  estr,wbond,ebe,wang,
1164      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1165      &  ecorr,wcorr,
1166      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1167      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1168      &  ehomology_constr,ebr*nss,Uconst,edfadis,wdfa_dist,edfator,
1169      &  wdfa_tor,edfanei,wdfa_nei,edfabet,wdfa_beta,
1170      &  etot
1171    10 format (/'Virtual-chain energies:'//
1172      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1173      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1174      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1175      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1176      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1177      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1178      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1179      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1180      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1181      & ' (SS bridges & dist. cnstr.)'/
1182      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1183      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1184      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1185      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1186      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1187      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1188      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1189      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1190      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1191      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1192      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1193      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1194      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
1195      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
1196      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
1197      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
1198      & 'ETOT=  ',1pE16.6,' (total)')
1199 #endif
1200       return
1201       end
1202 C-----------------------------------------------------------------------
1203       subroutine elj(evdw,evdw_p,evdw_m)
1204 C
1205 C This subroutine calculates the interaction energy of nonbonded side chains
1206 C assuming the LJ potential of interaction.
1207 C
1208       implicit real*8 (a-h,o-z)
1209       include 'DIMENSIONS'
1210       parameter (accur=1.0d-10)
1211       include 'COMMON.GEO'
1212       include 'COMMON.VAR'
1213       include 'COMMON.LOCAL'
1214       include 'COMMON.CHAIN'
1215       include 'COMMON.DERIV'
1216       include 'COMMON.INTERACT'
1217       include 'COMMON.TORSION'
1218       include 'COMMON.SBRIDGE'
1219       include 'COMMON.NAMES'
1220       include 'COMMON.IOUNITS'
1221       include 'COMMON.CONTACTS'
1222       dimension gg(3)
1223 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1224       evdw=0.0D0
1225       do i=iatsc_s,iatsc_e
1226         itypi=itype(i)
1227         itypi1=itype(i+1)
1228         xi=c(1,nres+i)
1229         yi=c(2,nres+i)
1230         zi=c(3,nres+i)
1231 C Change 12/1/95
1232         num_conti=0
1233 C
1234 C Calculate SC interaction energy.
1235 C
1236         do iint=1,nint_gr(i)
1237 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1238 cd   &                  'iend=',iend(i,iint)
1239           do j=istart(i,iint),iend(i,iint)
1240             itypj=itype(j)
1241             xj=c(1,nres+j)-xi
1242             yj=c(2,nres+j)-yi
1243             zj=c(3,nres+j)-zi
1244 C Change 12/1/95 to calculate four-body interactions
1245             rij=xj*xj+yj*yj+zj*zj
1246             rrij=1.0D0/rij
1247 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1248             eps0ij=eps(itypi,itypj)
1249             fac=rrij**expon2
1250             e1=fac*fac*aa(itypi,itypj)
1251             e2=fac*bb(itypi,itypj)
1252             evdwij=e1+e2
1253 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1254 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1255 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1256 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1257 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1258 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1259 #ifdef TSCSC
1260             if (bb(itypi,itypj).gt.0) then
1261                evdw_p=evdw_p+evdwij
1262             else
1263                evdw_m=evdw_m+evdwij
1264             endif
1265 #else
1266             evdw=evdw+evdwij
1267 #endif
1268 C
1269 C Calculate the components of the gradient in DC and X
1270 C
1271             fac=-rrij*(e1+evdwij)
1272             gg(1)=xj*fac
1273             gg(2)=yj*fac
1274             gg(3)=zj*fac
1275 #ifdef TSCSC
1276             if (bb(itypi,itypj).gt.0.0d0) then
1277               do k=1,3
1278                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1279                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1280                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1281                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1282               enddo
1283             else
1284               do k=1,3
1285                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1286                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1287                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1288                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1289               enddo
1290             endif
1291 #else
1292             do k=1,3
1293               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1294               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1295               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1296               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1297             enddo
1298 #endif
1299 cgrad            do k=i,j-1
1300 cgrad              do l=1,3
1301 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1302 cgrad              enddo
1303 cgrad            enddo
1304 C
1305 C 12/1/95, revised on 5/20/97
1306 C
1307 C Calculate the contact function. The ith column of the array JCONT will
1308 C contain the numbers of atoms that make contacts with the atom I (of numbers
1309 C greater than I). The arrays FACONT and GACONT will contain the values of
1310 C the contact function and its derivative.
1311 C
1312 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1313 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1314 C Uncomment next line, if the correlation interactions are contact function only
1315             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1316               rij=dsqrt(rij)
1317               sigij=sigma(itypi,itypj)
1318               r0ij=rs0(itypi,itypj)
1319 C
1320 C Check whether the SC's are not too far to make a contact.
1321 C
1322               rcut=1.5d0*r0ij
1323               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1324 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1325 C
1326               if (fcont.gt.0.0D0) then
1327 C If the SC-SC distance if close to sigma, apply spline.
1328 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1329 cAdam &             fcont1,fprimcont1)
1330 cAdam           fcont1=1.0d0-fcont1
1331 cAdam           if (fcont1.gt.0.0d0) then
1332 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1333 cAdam             fcont=fcont*fcont1
1334 cAdam           endif
1335 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1336 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1337 cga             do k=1,3
1338 cga               gg(k)=gg(k)*eps0ij
1339 cga             enddo
1340 cga             eps0ij=-evdwij*eps0ij
1341 C Uncomment for AL's type of SC correlation interactions.
1342 cadam           eps0ij=-evdwij
1343                 num_conti=num_conti+1
1344                 jcont(num_conti,i)=j
1345                 facont(num_conti,i)=fcont*eps0ij
1346                 fprimcont=eps0ij*fprimcont/rij
1347                 fcont=expon*fcont
1348 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1349 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1350 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1351 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1352                 gacont(1,num_conti,i)=-fprimcont*xj
1353                 gacont(2,num_conti,i)=-fprimcont*yj
1354                 gacont(3,num_conti,i)=-fprimcont*zj
1355 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1356 cd              write (iout,'(2i3,3f10.5)')
1357 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1358               endif
1359             endif
1360           enddo      ! j
1361         enddo        ! iint
1362 C Change 12/1/95
1363         num_cont(i)=num_conti
1364       enddo          ! i
1365       do i=1,nct
1366         do j=1,3
1367           gvdwc(j,i)=expon*gvdwc(j,i)
1368           gvdwx(j,i)=expon*gvdwx(j,i)
1369         enddo
1370       enddo
1371 C******************************************************************************
1372 C
1373 C                              N O T E !!!
1374 C
1375 C To save time, the factor of EXPON has been extracted from ALL components
1376 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1377 C use!
1378 C
1379 C******************************************************************************
1380       return
1381       end
1382 C-----------------------------------------------------------------------------
1383       subroutine eljk(evdw,evdw_p,evdw_m)
1384 C
1385 C This subroutine calculates the interaction energy of nonbonded side chains
1386 C assuming the LJK potential of interaction.
1387 C
1388       implicit real*8 (a-h,o-z)
1389       include 'DIMENSIONS'
1390       include 'COMMON.GEO'
1391       include 'COMMON.VAR'
1392       include 'COMMON.LOCAL'
1393       include 'COMMON.CHAIN'
1394       include 'COMMON.DERIV'
1395       include 'COMMON.INTERACT'
1396       include 'COMMON.IOUNITS'
1397       include 'COMMON.NAMES'
1398       dimension gg(3)
1399       logical scheck
1400 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1401       evdw=0.0D0
1402       do i=iatsc_s,iatsc_e
1403         itypi=itype(i)
1404         itypi1=itype(i+1)
1405         xi=c(1,nres+i)
1406         yi=c(2,nres+i)
1407         zi=c(3,nres+i)
1408 C
1409 C Calculate SC interaction energy.
1410 C
1411         do iint=1,nint_gr(i)
1412           do j=istart(i,iint),iend(i,iint)
1413             itypj=itype(j)
1414             xj=c(1,nres+j)-xi
1415             yj=c(2,nres+j)-yi
1416             zj=c(3,nres+j)-zi
1417             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1418             fac_augm=rrij**expon
1419             e_augm=augm(itypi,itypj)*fac_augm
1420             r_inv_ij=dsqrt(rrij)
1421             rij=1.0D0/r_inv_ij
1422             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1423             fac=r_shift_inv**expon
1424             e1=fac*fac*aa(itypi,itypj)
1425             e2=fac*bb(itypi,itypj)
1426             evdwij=e_augm+e1+e2
1427 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1428 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1429 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1430 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1431 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1432 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1433 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1434 #ifdef TSCSC
1435             if (bb(itypi,itypj).gt.0) then
1436                evdw_p=evdw_p+evdwij
1437             else
1438                evdw_m=evdw_m+evdwij
1439             endif
1440 #else
1441             evdw=evdw+evdwij
1442 #endif
1443 C
1444 C Calculate the components of the gradient in DC and X
1445 C
1446             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1447             gg(1)=xj*fac
1448             gg(2)=yj*fac
1449             gg(3)=zj*fac
1450 #ifdef TSCSC
1451             if (bb(itypi,itypj).gt.0.0d0) then
1452               do k=1,3
1453                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1454                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1455                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1456                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1457               enddo
1458             else
1459               do k=1,3
1460                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1461                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1462                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1463                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1464               enddo
1465             endif
1466 #else
1467             do k=1,3
1468               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1469               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1470               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1471               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1472             enddo
1473 #endif
1474 cgrad            do k=i,j-1
1475 cgrad              do l=1,3
1476 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1477 cgrad              enddo
1478 cgrad            enddo
1479           enddo      ! j
1480         enddo        ! iint
1481       enddo          ! i
1482       do i=1,nct
1483         do j=1,3
1484           gvdwc(j,i)=expon*gvdwc(j,i)
1485           gvdwx(j,i)=expon*gvdwx(j,i)
1486         enddo
1487       enddo
1488       return
1489       end
1490 C-----------------------------------------------------------------------------
1491       subroutine ebp(evdw,evdw_p,evdw_m)
1492 C
1493 C This subroutine calculates the interaction energy of nonbonded side chains
1494 C assuming the Berne-Pechukas potential of interaction.
1495 C
1496       implicit real*8 (a-h,o-z)
1497       include 'DIMENSIONS'
1498       include 'COMMON.GEO'
1499       include 'COMMON.VAR'
1500       include 'COMMON.LOCAL'
1501       include 'COMMON.CHAIN'
1502       include 'COMMON.DERIV'
1503       include 'COMMON.NAMES'
1504       include 'COMMON.INTERACT'
1505       include 'COMMON.IOUNITS'
1506       include 'COMMON.CALC'
1507       common /srutu/ icall
1508 c     double precision rrsave(maxdim)
1509       logical lprn
1510       evdw=0.0D0
1511 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1512       evdw=0.0D0
1513 c     if (icall.eq.0) then
1514 c       lprn=.true.
1515 c     else
1516         lprn=.false.
1517 c     endif
1518       ind=0
1519       do i=iatsc_s,iatsc_e
1520         itypi=itype(i)
1521         itypi1=itype(i+1)
1522         xi=c(1,nres+i)
1523         yi=c(2,nres+i)
1524         zi=c(3,nres+i)
1525         dxi=dc_norm(1,nres+i)
1526         dyi=dc_norm(2,nres+i)
1527         dzi=dc_norm(3,nres+i)
1528 c        dsci_inv=dsc_inv(itypi)
1529         dsci_inv=vbld_inv(i+nres)
1530 C
1531 C Calculate SC interaction energy.
1532 C
1533         do iint=1,nint_gr(i)
1534           do j=istart(i,iint),iend(i,iint)
1535             ind=ind+1
1536             itypj=itype(j)
1537 c            dscj_inv=dsc_inv(itypj)
1538             dscj_inv=vbld_inv(j+nres)
1539             chi1=chi(itypi,itypj)
1540             chi2=chi(itypj,itypi)
1541             chi12=chi1*chi2
1542             chip1=chip(itypi)
1543             chip2=chip(itypj)
1544             chip12=chip1*chip2
1545             alf1=alp(itypi)
1546             alf2=alp(itypj)
1547             alf12=0.5D0*(alf1+alf2)
1548 C For diagnostics only!!!
1549 c           chi1=0.0D0
1550 c           chi2=0.0D0
1551 c           chi12=0.0D0
1552 c           chip1=0.0D0
1553 c           chip2=0.0D0
1554 c           chip12=0.0D0
1555 c           alf1=0.0D0
1556 c           alf2=0.0D0
1557 c           alf12=0.0D0
1558             xj=c(1,nres+j)-xi
1559             yj=c(2,nres+j)-yi
1560             zj=c(3,nres+j)-zi
1561             dxj=dc_norm(1,nres+j)
1562             dyj=dc_norm(2,nres+j)
1563             dzj=dc_norm(3,nres+j)
1564             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1565 cd          if (icall.eq.0) then
1566 cd            rrsave(ind)=rrij
1567 cd          else
1568 cd            rrij=rrsave(ind)
1569 cd          endif
1570             rij=dsqrt(rrij)
1571 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1572             call sc_angular
1573 C Calculate whole angle-dependent part of epsilon and contributions
1574 C to its derivatives
1575             fac=(rrij*sigsq)**expon2
1576             e1=fac*fac*aa(itypi,itypj)
1577             e2=fac*bb(itypi,itypj)
1578             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1579             eps2der=evdwij*eps3rt
1580             eps3der=evdwij*eps2rt
1581             evdwij=evdwij*eps2rt*eps3rt
1582 #ifdef TSCSC
1583             if (bb(itypi,itypj).gt.0) then
1584                evdw_p=evdw_p+evdwij
1585             else
1586                evdw_m=evdw_m+evdwij
1587             endif
1588 #else
1589             evdw=evdw+evdwij
1590 #endif
1591             if (lprn) then
1592             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1593             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1594 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1595 cd     &        restyp(itypi),i,restyp(itypj),j,
1596 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1597 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1598 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1599 cd     &        evdwij
1600             endif
1601 C Calculate gradient components.
1602             e1=e1*eps1*eps2rt**2*eps3rt**2
1603             fac=-expon*(e1+evdwij)
1604             sigder=fac/sigsq
1605             fac=rrij*fac
1606 C Calculate radial part of the gradient
1607             gg(1)=xj*fac
1608             gg(2)=yj*fac
1609             gg(3)=zj*fac
1610 C Calculate the angular part of the gradient and sum add the contributions
1611 C to the appropriate components of the Cartesian gradient.
1612 #ifdef TSCSC
1613             if (bb(itypi,itypj).gt.0) then
1614                call sc_grad
1615             else
1616                call sc_grad_T
1617             endif
1618 #else
1619             call sc_grad
1620 #endif
1621           enddo      ! j
1622         enddo        ! iint
1623       enddo          ! i
1624 c     stop
1625       return
1626       end
1627 C-----------------------------------------------------------------------------
1628       subroutine egb(evdw,evdw_p,evdw_m)
1629 C
1630 C This subroutine calculates the interaction energy of nonbonded side chains
1631 C assuming the Gay-Berne potential of interaction.
1632 C
1633       implicit real*8 (a-h,o-z)
1634       include 'DIMENSIONS'
1635       include 'COMMON.GEO'
1636       include 'COMMON.VAR'
1637       include 'COMMON.LOCAL'
1638       include 'COMMON.CHAIN'
1639       include 'COMMON.DERIV'
1640       include 'COMMON.NAMES'
1641       include 'COMMON.INTERACT'
1642       include 'COMMON.IOUNITS'
1643       include 'COMMON.CALC'
1644       include 'COMMON.CONTROL'
1645       include 'COMMON.SBRIDGE'
1646       logical lprn
1647       evdw=0.0D0
1648 ccccc      energy_dec=.false.
1649 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1650       evdw=0.0D0
1651       evdw_p=0.0D0
1652       evdw_m=0.0D0
1653       lprn=.false.
1654 c     if (icall.eq.0) lprn=.false.
1655       ind=0
1656       do i=iatsc_s,iatsc_e
1657         itypi=itype(i)
1658         itypi1=itype(i+1)
1659         xi=c(1,nres+i)
1660         yi=c(2,nres+i)
1661         zi=c(3,nres+i)
1662         dxi=dc_norm(1,nres+i)
1663         dyi=dc_norm(2,nres+i)
1664         dzi=dc_norm(3,nres+i)
1665 c        dsci_inv=dsc_inv(itypi)
1666         dsci_inv=vbld_inv(i+nres)
1667 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1668 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1669 C
1670 C Calculate SC interaction energy.
1671 C
1672         do iint=1,nint_gr(i)
1673           do j=istart(i,iint),iend(i,iint)
1674             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1675               call dyn_ssbond_ene(i,j,evdwij)
1676               evdw=evdw+evdwij
1677               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1678      &                        'evdw',i,j,evdwij,' ss'
1679             ELSE
1680             ind=ind+1
1681             itypj=itype(j)
1682 c            dscj_inv=dsc_inv(itypj)
1683             dscj_inv=vbld_inv(j+nres)
1684 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1685 c     &       1.0d0/vbld(j+nres)
1686 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1687             sig0ij=sigma(itypi,itypj)
1688             chi1=chi(itypi,itypj)
1689             chi2=chi(itypj,itypi)
1690             chi12=chi1*chi2
1691             chip1=chip(itypi)
1692             chip2=chip(itypj)
1693             chip12=chip1*chip2
1694             alf1=alp(itypi)
1695             alf2=alp(itypj)
1696             alf12=0.5D0*(alf1+alf2)
1697 C For diagnostics only!!!
1698 c           chi1=0.0D0
1699 c           chi2=0.0D0
1700 c           chi12=0.0D0
1701 c           chip1=0.0D0
1702 c           chip2=0.0D0
1703 c           chip12=0.0D0
1704 c           alf1=0.0D0
1705 c           alf2=0.0D0
1706 c           alf12=0.0D0
1707             xj=c(1,nres+j)-xi
1708             yj=c(2,nres+j)-yi
1709             zj=c(3,nres+j)-zi
1710             dxj=dc_norm(1,nres+j)
1711             dyj=dc_norm(2,nres+j)
1712             dzj=dc_norm(3,nres+j)
1713 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1714 c            write (iout,*) "j",j," dc_norm",
1715 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1716             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1717             rij=dsqrt(rrij)
1718 C Calculate angle-dependent terms of energy and contributions to their
1719 C derivatives.
1720             call sc_angular
1721             sigsq=1.0D0/sigsq
1722             sig=sig0ij*dsqrt(sigsq)
1723             rij_shift=1.0D0/rij-sig+sig0ij
1724 c for diagnostics; uncomment
1725 c            rij_shift=1.2*sig0ij
1726 C I hate to put IF's in the loops, but here don't have another choice!!!!
1727             if (rij_shift.le.0.0D0) then
1728               evdw=1.0D20
1729 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1730 cd     &        restyp(itypi),i,restyp(itypj),j,
1731 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1732               return
1733             endif
1734             sigder=-sig*sigsq
1735 c---------------------------------------------------------------
1736             rij_shift=1.0D0/rij_shift
1737             fac=rij_shift**expon
1738             e1=fac*fac*aa(itypi,itypj)
1739             e2=fac*bb(itypi,itypj)
1740             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1741             eps2der=evdwij*eps3rt
1742             eps3der=evdwij*eps2rt
1743 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1744 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1745             evdwij=evdwij*eps2rt*eps3rt
1746 #ifdef TSCSC
1747             if (bb(itypi,itypj).gt.0) then
1748                evdw_p=evdw_p+evdwij
1749             else
1750                evdw_m=evdw_m+evdwij
1751             endif
1752 #else
1753             evdw=evdw+evdwij
1754 #endif
1755             if (lprn) then
1756             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1757             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1758             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1759      &        restyp(itypi),i,restyp(itypj),j,
1760      &        epsi,sigm,chi1,chi2,chip1,chip2,
1761      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1762      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1763      &        evdwij
1764             endif
1765
1766             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1767      &                        'evdw',i,j,evdwij
1768
1769 C Calculate gradient components.
1770             e1=e1*eps1*eps2rt**2*eps3rt**2
1771             fac=-expon*(e1+evdwij)*rij_shift
1772             sigder=fac*sigder
1773             fac=rij*fac
1774 c            fac=0.0d0
1775 C Calculate the radial part of the gradient
1776             gg(1)=xj*fac
1777             gg(2)=yj*fac
1778             gg(3)=zj*fac
1779 C Calculate angular part of the gradient.
1780 #ifdef TSCSC
1781             if (bb(itypi,itypj).gt.0) then
1782                call sc_grad
1783             else
1784                call sc_grad_T
1785             endif
1786 #else
1787             call sc_grad
1788 #endif
1789             ENDIF    ! dyn_ss
1790           enddo      ! j
1791         enddo        ! iint
1792       enddo          ! i
1793 c      write (iout,*) "Number of loop steps in EGB:",ind
1794 cccc      energy_dec=.false.
1795       return
1796       end
1797 C-----------------------------------------------------------------------------
1798       subroutine egbv(evdw,evdw_p,evdw_m)
1799 C
1800 C This subroutine calculates the interaction energy of nonbonded side chains
1801 C assuming the Gay-Berne-Vorobjev potential of interaction.
1802 C
1803       implicit real*8 (a-h,o-z)
1804       include 'DIMENSIONS'
1805       include 'COMMON.GEO'
1806       include 'COMMON.VAR'
1807       include 'COMMON.LOCAL'
1808       include 'COMMON.CHAIN'
1809       include 'COMMON.DERIV'
1810       include 'COMMON.NAMES'
1811       include 'COMMON.INTERACT'
1812       include 'COMMON.IOUNITS'
1813       include 'COMMON.CALC'
1814       common /srutu/ icall
1815       logical lprn
1816       evdw=0.0D0
1817 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1818       evdw=0.0D0
1819       lprn=.false.
1820 c     if (icall.eq.0) lprn=.true.
1821       ind=0
1822       do i=iatsc_s,iatsc_e
1823         itypi=itype(i)
1824         itypi1=itype(i+1)
1825         xi=c(1,nres+i)
1826         yi=c(2,nres+i)
1827         zi=c(3,nres+i)
1828         dxi=dc_norm(1,nres+i)
1829         dyi=dc_norm(2,nres+i)
1830         dzi=dc_norm(3,nres+i)
1831 c        dsci_inv=dsc_inv(itypi)
1832         dsci_inv=vbld_inv(i+nres)
1833 C
1834 C Calculate SC interaction energy.
1835 C
1836         do iint=1,nint_gr(i)
1837           do j=istart(i,iint),iend(i,iint)
1838             ind=ind+1
1839             itypj=itype(j)
1840 c            dscj_inv=dsc_inv(itypj)
1841             dscj_inv=vbld_inv(j+nres)
1842             sig0ij=sigma(itypi,itypj)
1843             r0ij=r0(itypi,itypj)
1844             chi1=chi(itypi,itypj)
1845             chi2=chi(itypj,itypi)
1846             chi12=chi1*chi2
1847             chip1=chip(itypi)
1848             chip2=chip(itypj)
1849             chip12=chip1*chip2
1850             alf1=alp(itypi)
1851             alf2=alp(itypj)
1852             alf12=0.5D0*(alf1+alf2)
1853 C For diagnostics only!!!
1854 c           chi1=0.0D0
1855 c           chi2=0.0D0
1856 c           chi12=0.0D0
1857 c           chip1=0.0D0
1858 c           chip2=0.0D0
1859 c           chip12=0.0D0
1860 c           alf1=0.0D0
1861 c           alf2=0.0D0
1862 c           alf12=0.0D0
1863             xj=c(1,nres+j)-xi
1864             yj=c(2,nres+j)-yi
1865             zj=c(3,nres+j)-zi
1866             dxj=dc_norm(1,nres+j)
1867             dyj=dc_norm(2,nres+j)
1868             dzj=dc_norm(3,nres+j)
1869             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1870             rij=dsqrt(rrij)
1871 C Calculate angle-dependent terms of energy and contributions to their
1872 C derivatives.
1873             call sc_angular
1874             sigsq=1.0D0/sigsq
1875             sig=sig0ij*dsqrt(sigsq)
1876             rij_shift=1.0D0/rij-sig+r0ij
1877 C I hate to put IF's in the loops, but here don't have another choice!!!!
1878             if (rij_shift.le.0.0D0) then
1879               evdw=1.0D20
1880               return
1881             endif
1882             sigder=-sig*sigsq
1883 c---------------------------------------------------------------
1884             rij_shift=1.0D0/rij_shift
1885             fac=rij_shift**expon
1886             e1=fac*fac*aa(itypi,itypj)
1887             e2=fac*bb(itypi,itypj)
1888             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1889             eps2der=evdwij*eps3rt
1890             eps3der=evdwij*eps2rt
1891             fac_augm=rrij**expon
1892             e_augm=augm(itypi,itypj)*fac_augm
1893             evdwij=evdwij*eps2rt*eps3rt
1894 #ifdef TSCSC
1895             if (bb(itypi,itypj).gt.0) then
1896                evdw_p=evdw_p+evdwij+e_augm
1897             else
1898                evdw_m=evdw_m+evdwij+e_augm
1899             endif
1900 #else
1901             evdw=evdw+evdwij+e_augm
1902 #endif
1903             if (lprn) then
1904             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1905             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1906             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1907      &        restyp(itypi),i,restyp(itypj),j,
1908      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1909      &        chi1,chi2,chip1,chip2,
1910      &        eps1,eps2rt**2,eps3rt**2,
1911      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1912      &        evdwij+e_augm
1913             endif
1914 C Calculate gradient components.
1915             e1=e1*eps1*eps2rt**2*eps3rt**2
1916             fac=-expon*(e1+evdwij)*rij_shift
1917             sigder=fac*sigder
1918             fac=rij*fac-2*expon*rrij*e_augm
1919 C Calculate the radial part of the gradient
1920             gg(1)=xj*fac
1921             gg(2)=yj*fac
1922             gg(3)=zj*fac
1923 C Calculate angular part of the gradient.
1924 #ifdef TSCSC
1925             if (bb(itypi,itypj).gt.0) then
1926                call sc_grad
1927             else
1928                call sc_grad_T
1929             endif
1930 #else
1931             call sc_grad
1932 #endif
1933           enddo      ! j
1934         enddo        ! iint
1935       enddo          ! i
1936       end
1937 C-----------------------------------------------------------------------------
1938       subroutine sc_angular
1939 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1940 C om12. Called by ebp, egb, and egbv.
1941       implicit none
1942       include 'COMMON.CALC'
1943       include 'COMMON.IOUNITS'
1944       erij(1)=xj*rij
1945       erij(2)=yj*rij
1946       erij(3)=zj*rij
1947       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1948       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1949       om12=dxi*dxj+dyi*dyj+dzi*dzj
1950       chiom12=chi12*om12
1951 C Calculate eps1(om12) and its derivative in om12
1952       faceps1=1.0D0-om12*chiom12
1953       faceps1_inv=1.0D0/faceps1
1954       eps1=dsqrt(faceps1_inv)
1955 C Following variable is eps1*deps1/dom12
1956       eps1_om12=faceps1_inv*chiom12
1957 c diagnostics only
1958 c      faceps1_inv=om12
1959 c      eps1=om12
1960 c      eps1_om12=1.0d0
1961 c      write (iout,*) "om12",om12," eps1",eps1
1962 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1963 C and om12.
1964       om1om2=om1*om2
1965       chiom1=chi1*om1
1966       chiom2=chi2*om2
1967       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1968       sigsq=1.0D0-facsig*faceps1_inv
1969       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1970       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1971       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1972 c diagnostics only
1973 c      sigsq=1.0d0
1974 c      sigsq_om1=0.0d0
1975 c      sigsq_om2=0.0d0
1976 c      sigsq_om12=0.0d0
1977 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1978 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1979 c     &    " eps1",eps1
1980 C Calculate eps2 and its derivatives in om1, om2, and om12.
1981       chipom1=chip1*om1
1982       chipom2=chip2*om2
1983       chipom12=chip12*om12
1984       facp=1.0D0-om12*chipom12
1985       facp_inv=1.0D0/facp
1986       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1987 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1988 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1989 C Following variable is the square root of eps2
1990       eps2rt=1.0D0-facp1*facp_inv
1991 C Following three variables are the derivatives of the square root of eps
1992 C in om1, om2, and om12.
1993       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1994       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1995       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1996 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1997       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1998 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1999 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2000 c     &  " eps2rt_om12",eps2rt_om12
2001 C Calculate whole angle-dependent part of epsilon and contributions
2002 C to its derivatives
2003       return
2004       end
2005
2006 C----------------------------------------------------------------------------
2007       subroutine sc_grad_T
2008       implicit real*8 (a-h,o-z)
2009       include 'DIMENSIONS'
2010       include 'COMMON.CHAIN'
2011       include 'COMMON.DERIV'
2012       include 'COMMON.CALC'
2013       include 'COMMON.IOUNITS'
2014       double precision dcosom1(3),dcosom2(3)
2015       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2016       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2017       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2018      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2019 c diagnostics only
2020 c      eom1=0.0d0
2021 c      eom2=0.0d0
2022 c      eom12=evdwij*eps1_om12
2023 c end diagnostics
2024 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2025 c     &  " sigder",sigder
2026 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2027 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2028       do k=1,3
2029         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2030         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2031       enddo
2032       do k=1,3
2033         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2034       enddo
2035 c      write (iout,*) "gg",(gg(k),k=1,3)
2036       do k=1,3
2037         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
2038      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2039      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2040         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
2041      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2042      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2043 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2044 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2045 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2046 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2047       enddo
2048 C
2049 C Calculate the components of the gradient in DC and X
2050 C
2051 cgrad      do k=i,j-1
2052 cgrad        do l=1,3
2053 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2054 cgrad        enddo
2055 cgrad      enddo
2056       do l=1,3
2057         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
2058         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
2059       enddo
2060       return
2061       end
2062
2063 C----------------------------------------------------------------------------
2064       subroutine sc_grad
2065       implicit real*8 (a-h,o-z)
2066       include 'DIMENSIONS'
2067       include 'COMMON.CHAIN'
2068       include 'COMMON.DERIV'
2069       include 'COMMON.CALC'
2070       include 'COMMON.IOUNITS'
2071       double precision dcosom1(3),dcosom2(3)
2072       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2073       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2074       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2075      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2076 c diagnostics only
2077 c      eom1=0.0d0
2078 c      eom2=0.0d0
2079 c      eom12=evdwij*eps1_om12
2080 c end diagnostics
2081 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2082 c     &  " sigder",sigder
2083 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2084 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2085       do k=1,3
2086         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2087         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2088       enddo
2089       do k=1,3
2090         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2091       enddo
2092 c      write (iout,*) "gg",(gg(k),k=1,3)
2093       do k=1,3
2094         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2095      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2096      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2097         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2098      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2099      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2100 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2101 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2102 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2103 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2104       enddo
2105 C
2106 C Calculate the components of the gradient in DC and X
2107 C
2108 cgrad      do k=i,j-1
2109 cgrad        do l=1,3
2110 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2111 cgrad        enddo
2112 cgrad      enddo
2113       do l=1,3
2114         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2115         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2116       enddo
2117       return
2118       end
2119 C-----------------------------------------------------------------------
2120       subroutine e_softsphere(evdw)
2121 C
2122 C This subroutine calculates the interaction energy of nonbonded side chains
2123 C assuming the LJ potential of interaction.
2124 C
2125       implicit real*8 (a-h,o-z)
2126       include 'DIMENSIONS'
2127       parameter (accur=1.0d-10)
2128       include 'COMMON.GEO'
2129       include 'COMMON.VAR'
2130       include 'COMMON.LOCAL'
2131       include 'COMMON.CHAIN'
2132       include 'COMMON.DERIV'
2133       include 'COMMON.INTERACT'
2134       include 'COMMON.TORSION'
2135       include 'COMMON.SBRIDGE'
2136       include 'COMMON.NAMES'
2137       include 'COMMON.IOUNITS'
2138       include 'COMMON.CONTACTS'
2139       dimension gg(3)
2140 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2141       evdw=0.0D0
2142       do i=iatsc_s,iatsc_e
2143         itypi=itype(i)
2144         itypi1=itype(i+1)
2145         xi=c(1,nres+i)
2146         yi=c(2,nres+i)
2147         zi=c(3,nres+i)
2148 C
2149 C Calculate SC interaction energy.
2150 C
2151         do iint=1,nint_gr(i)
2152 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2153 cd   &                  'iend=',iend(i,iint)
2154           do j=istart(i,iint),iend(i,iint)
2155             itypj=itype(j)
2156             xj=c(1,nres+j)-xi
2157             yj=c(2,nres+j)-yi
2158             zj=c(3,nres+j)-zi
2159             rij=xj*xj+yj*yj+zj*zj
2160 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2161             r0ij=r0(itypi,itypj)
2162             r0ijsq=r0ij*r0ij
2163 c            print *,i,j,r0ij,dsqrt(rij)
2164             if (rij.lt.r0ijsq) then
2165               evdwij=0.25d0*(rij-r0ijsq)**2
2166               fac=rij-r0ijsq
2167             else
2168               evdwij=0.0d0
2169               fac=0.0d0
2170             endif
2171             evdw=evdw+evdwij
2172 C
2173 C Calculate the components of the gradient in DC and X
2174 C
2175             gg(1)=xj*fac
2176             gg(2)=yj*fac
2177             gg(3)=zj*fac
2178             do k=1,3
2179               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2180               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2181               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2182               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2183             enddo
2184 cgrad            do k=i,j-1
2185 cgrad              do l=1,3
2186 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2187 cgrad              enddo
2188 cgrad            enddo
2189           enddo ! j
2190         enddo ! iint
2191       enddo ! i
2192       return
2193       end
2194 C--------------------------------------------------------------------------
2195       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2196      &              eello_turn4)
2197 C
2198 C Soft-sphere potential of p-p interaction
2199 C
2200       implicit real*8 (a-h,o-z)
2201       include 'DIMENSIONS'
2202       include 'COMMON.CONTROL'
2203       include 'COMMON.IOUNITS'
2204       include 'COMMON.GEO'
2205       include 'COMMON.VAR'
2206       include 'COMMON.LOCAL'
2207       include 'COMMON.CHAIN'
2208       include 'COMMON.DERIV'
2209       include 'COMMON.INTERACT'
2210       include 'COMMON.CONTACTS'
2211       include 'COMMON.TORSION'
2212       include 'COMMON.VECTORS'
2213       include 'COMMON.FFIELD'
2214       dimension ggg(3)
2215 cd      write(iout,*) 'In EELEC_soft_sphere'
2216       ees=0.0D0
2217       evdw1=0.0D0
2218       eel_loc=0.0d0
2219       eello_turn3=0.0d0
2220       eello_turn4=0.0d0
2221       ind=0
2222       do i=iatel_s,iatel_e
2223         dxi=dc(1,i)
2224         dyi=dc(2,i)
2225         dzi=dc(3,i)
2226         xmedi=c(1,i)+0.5d0*dxi
2227         ymedi=c(2,i)+0.5d0*dyi
2228         zmedi=c(3,i)+0.5d0*dzi
2229         num_conti=0
2230 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2231         do j=ielstart(i),ielend(i)
2232           ind=ind+1
2233           iteli=itel(i)
2234           itelj=itel(j)
2235           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2236           r0ij=rpp(iteli,itelj)
2237           r0ijsq=r0ij*r0ij
2238           dxj=dc(1,j)
2239           dyj=dc(2,j)
2240           dzj=dc(3,j)
2241           xj=c(1,j)+0.5D0*dxj-xmedi
2242           yj=c(2,j)+0.5D0*dyj-ymedi
2243           zj=c(3,j)+0.5D0*dzj-zmedi
2244           rij=xj*xj+yj*yj+zj*zj
2245           if (rij.lt.r0ijsq) then
2246             evdw1ij=0.25d0*(rij-r0ijsq)**2
2247             fac=rij-r0ijsq
2248           else
2249             evdw1ij=0.0d0
2250             fac=0.0d0
2251           endif
2252           evdw1=evdw1+evdw1ij
2253 C
2254 C Calculate contributions to the Cartesian gradient.
2255 C
2256           ggg(1)=fac*xj
2257           ggg(2)=fac*yj
2258           ggg(3)=fac*zj
2259           do k=1,3
2260             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2261             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2262           enddo
2263 *
2264 * Loop over residues i+1 thru j-1.
2265 *
2266 cgrad          do k=i+1,j-1
2267 cgrad            do l=1,3
2268 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2269 cgrad            enddo
2270 cgrad          enddo
2271         enddo ! j
2272       enddo   ! i
2273 cgrad      do i=nnt,nct-1
2274 cgrad        do k=1,3
2275 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2276 cgrad        enddo
2277 cgrad        do j=i+1,nct-1
2278 cgrad          do k=1,3
2279 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2280 cgrad          enddo
2281 cgrad        enddo
2282 cgrad      enddo
2283       return
2284       end
2285 c------------------------------------------------------------------------------
2286       subroutine vec_and_deriv
2287       implicit real*8 (a-h,o-z)
2288       include 'DIMENSIONS'
2289 #ifdef MPI
2290       include 'mpif.h'
2291 #endif
2292       include 'COMMON.IOUNITS'
2293       include 'COMMON.GEO'
2294       include 'COMMON.VAR'
2295       include 'COMMON.LOCAL'
2296       include 'COMMON.CHAIN'
2297       include 'COMMON.VECTORS'
2298       include 'COMMON.SETUP'
2299       include 'COMMON.TIME1'
2300       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2301 C Compute the local reference systems. For reference system (i), the
2302 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2303 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2304 #ifdef PARVEC
2305       do i=ivec_start,ivec_end
2306 #else
2307       do i=1,nres-1
2308 #endif
2309           if (i.eq.nres-1) then
2310 C Case of the last full residue
2311 C Compute the Z-axis
2312             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2313             costh=dcos(pi-theta(nres))
2314             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2315             do k=1,3
2316               uz(k,i)=fac*uz(k,i)
2317             enddo
2318 C Compute the derivatives of uz
2319             uzder(1,1,1)= 0.0d0
2320             uzder(2,1,1)=-dc_norm(3,i-1)
2321             uzder(3,1,1)= dc_norm(2,i-1)
2322             uzder(1,2,1)= dc_norm(3,i-1)
2323             uzder(2,2,1)= 0.0d0
2324             uzder(3,2,1)=-dc_norm(1,i-1)
2325             uzder(1,3,1)=-dc_norm(2,i-1)
2326             uzder(2,3,1)= dc_norm(1,i-1)
2327             uzder(3,3,1)= 0.0d0
2328             uzder(1,1,2)= 0.0d0
2329             uzder(2,1,2)= dc_norm(3,i)
2330             uzder(3,1,2)=-dc_norm(2,i)
2331             uzder(1,2,2)=-dc_norm(3,i)
2332             uzder(2,2,2)= 0.0d0
2333             uzder(3,2,2)= dc_norm(1,i)
2334             uzder(1,3,2)= dc_norm(2,i)
2335             uzder(2,3,2)=-dc_norm(1,i)
2336             uzder(3,3,2)= 0.0d0
2337 C Compute the Y-axis
2338             facy=fac
2339             do k=1,3
2340               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2341             enddo
2342 C Compute the derivatives of uy
2343             do j=1,3
2344               do k=1,3
2345                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2346      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2347                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2348               enddo
2349               uyder(j,j,1)=uyder(j,j,1)-costh
2350               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2351             enddo
2352             do j=1,2
2353               do k=1,3
2354                 do l=1,3
2355                   uygrad(l,k,j,i)=uyder(l,k,j)
2356                   uzgrad(l,k,j,i)=uzder(l,k,j)
2357                 enddo
2358               enddo
2359             enddo
2360             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2361             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2362             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2363             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2364           else
2365 C Other residues
2366 C Compute the Z-axis
2367             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2368             costh=dcos(pi-theta(i+2))
2369             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2370             do k=1,3
2371               uz(k,i)=fac*uz(k,i)
2372             enddo
2373 C Compute the derivatives of uz
2374             uzder(1,1,1)= 0.0d0
2375             uzder(2,1,1)=-dc_norm(3,i+1)
2376             uzder(3,1,1)= dc_norm(2,i+1)
2377             uzder(1,2,1)= dc_norm(3,i+1)
2378             uzder(2,2,1)= 0.0d0
2379             uzder(3,2,1)=-dc_norm(1,i+1)
2380             uzder(1,3,1)=-dc_norm(2,i+1)
2381             uzder(2,3,1)= dc_norm(1,i+1)
2382             uzder(3,3,1)= 0.0d0
2383             uzder(1,1,2)= 0.0d0
2384             uzder(2,1,2)= dc_norm(3,i)
2385             uzder(3,1,2)=-dc_norm(2,i)
2386             uzder(1,2,2)=-dc_norm(3,i)
2387             uzder(2,2,2)= 0.0d0
2388             uzder(3,2,2)= dc_norm(1,i)
2389             uzder(1,3,2)= dc_norm(2,i)
2390             uzder(2,3,2)=-dc_norm(1,i)
2391             uzder(3,3,2)= 0.0d0
2392 C Compute the Y-axis
2393             facy=fac
2394             do k=1,3
2395               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2396             enddo
2397 C Compute the derivatives of uy
2398             do j=1,3
2399               do k=1,3
2400                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2401      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2402                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2403               enddo
2404               uyder(j,j,1)=uyder(j,j,1)-costh
2405               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2406             enddo
2407             do j=1,2
2408               do k=1,3
2409                 do l=1,3
2410                   uygrad(l,k,j,i)=uyder(l,k,j)
2411                   uzgrad(l,k,j,i)=uzder(l,k,j)
2412                 enddo
2413               enddo
2414             enddo
2415             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2416             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2417             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2418             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2419           endif
2420       enddo
2421       do i=1,nres-1
2422         vbld_inv_temp(1)=vbld_inv(i+1)
2423         if (i.lt.nres-1) then
2424           vbld_inv_temp(2)=vbld_inv(i+2)
2425           else
2426           vbld_inv_temp(2)=vbld_inv(i)
2427           endif
2428         do j=1,2
2429           do k=1,3
2430             do l=1,3
2431               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2432               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2433             enddo
2434           enddo
2435         enddo
2436       enddo
2437 #if defined(PARVEC) && defined(MPI)
2438       if (nfgtasks1.gt.1) then
2439         time00=MPI_Wtime()
2440 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2441 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2442 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2443         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2444      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2445      &   FG_COMM1,IERR)
2446         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2447      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2448      &   FG_COMM1,IERR)
2449         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2450      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2451      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2452         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2453      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2454      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2455         time_gather=time_gather+MPI_Wtime()-time00
2456       endif
2457 c      if (fg_rank.eq.0) then
2458 c        write (iout,*) "Arrays UY and UZ"
2459 c        do i=1,nres-1
2460 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2461 c     &     (uz(k,i),k=1,3)
2462 c        enddo
2463 c      endif
2464 #endif
2465       return
2466       end
2467 C-----------------------------------------------------------------------------
2468       subroutine check_vecgrad
2469       implicit real*8 (a-h,o-z)
2470       include 'DIMENSIONS'
2471       include 'COMMON.IOUNITS'
2472       include 'COMMON.GEO'
2473       include 'COMMON.VAR'
2474       include 'COMMON.LOCAL'
2475       include 'COMMON.CHAIN'
2476       include 'COMMON.VECTORS'
2477       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2478       dimension uyt(3,maxres),uzt(3,maxres)
2479       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2480       double precision delta /1.0d-7/
2481       call vec_and_deriv
2482 cd      do i=1,nres
2483 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2484 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2485 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2486 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2487 cd     &     (dc_norm(if90,i),if90=1,3)
2488 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2489 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2490 cd          write(iout,'(a)')
2491 cd      enddo
2492       do i=1,nres
2493         do j=1,2
2494           do k=1,3
2495             do l=1,3
2496               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2497               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2498             enddo
2499           enddo
2500         enddo
2501       enddo
2502       call vec_and_deriv
2503       do i=1,nres
2504         do j=1,3
2505           uyt(j,i)=uy(j,i)
2506           uzt(j,i)=uz(j,i)
2507         enddo
2508       enddo
2509       do i=1,nres
2510 cd        write (iout,*) 'i=',i
2511         do k=1,3
2512           erij(k)=dc_norm(k,i)
2513         enddo
2514         do j=1,3
2515           do k=1,3
2516             dc_norm(k,i)=erij(k)
2517           enddo
2518           dc_norm(j,i)=dc_norm(j,i)+delta
2519 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2520 c          do k=1,3
2521 c            dc_norm(k,i)=dc_norm(k,i)/fac
2522 c          enddo
2523 c          write (iout,*) (dc_norm(k,i),k=1,3)
2524 c          write (iout,*) (erij(k),k=1,3)
2525           call vec_and_deriv
2526           do k=1,3
2527             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2528             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2529             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2530             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2531           enddo
2532 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2533 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2534 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2535         enddo
2536         do k=1,3
2537           dc_norm(k,i)=erij(k)
2538         enddo
2539 cd        do k=1,3
2540 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2541 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2542 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2543 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2544 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2545 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2546 cd          write (iout,'(a)')
2547 cd        enddo
2548       enddo
2549       return
2550       end
2551 C--------------------------------------------------------------------------
2552       subroutine set_matrices
2553       implicit real*8 (a-h,o-z)
2554       include 'DIMENSIONS'
2555 #ifdef MPI
2556       include "mpif.h"
2557       include "COMMON.SETUP"
2558       integer IERR
2559       integer status(MPI_STATUS_SIZE)
2560 #endif
2561       include 'COMMON.IOUNITS'
2562       include 'COMMON.GEO'
2563       include 'COMMON.VAR'
2564       include 'COMMON.LOCAL'
2565       include 'COMMON.CHAIN'
2566       include 'COMMON.DERIV'
2567       include 'COMMON.INTERACT'
2568       include 'COMMON.CONTACTS'
2569       include 'COMMON.TORSION'
2570       include 'COMMON.VECTORS'
2571       include 'COMMON.FFIELD'
2572       double precision auxvec(2),auxmat(2,2)
2573 C
2574 C Compute the virtual-bond-torsional-angle dependent quantities needed
2575 C to calculate the el-loc multibody terms of various order.
2576 C
2577 #ifdef PARMAT
2578       do i=ivec_start+2,ivec_end+2
2579 #else
2580       do i=3,nres+1
2581 #endif
2582         if (i .lt. nres+1) then
2583           sin1=dsin(phi(i))
2584           cos1=dcos(phi(i))
2585           sintab(i-2)=sin1
2586           costab(i-2)=cos1
2587           obrot(1,i-2)=cos1
2588           obrot(2,i-2)=sin1
2589           sin2=dsin(2*phi(i))
2590           cos2=dcos(2*phi(i))
2591           sintab2(i-2)=sin2
2592           costab2(i-2)=cos2
2593           obrot2(1,i-2)=cos2
2594           obrot2(2,i-2)=sin2
2595           Ug(1,1,i-2)=-cos1
2596           Ug(1,2,i-2)=-sin1
2597           Ug(2,1,i-2)=-sin1
2598           Ug(2,2,i-2)= cos1
2599           Ug2(1,1,i-2)=-cos2
2600           Ug2(1,2,i-2)=-sin2
2601           Ug2(2,1,i-2)=-sin2
2602           Ug2(2,2,i-2)= cos2
2603         else
2604           costab(i-2)=1.0d0
2605           sintab(i-2)=0.0d0
2606           obrot(1,i-2)=1.0d0
2607           obrot(2,i-2)=0.0d0
2608           obrot2(1,i-2)=0.0d0
2609           obrot2(2,i-2)=0.0d0
2610           Ug(1,1,i-2)=1.0d0
2611           Ug(1,2,i-2)=0.0d0
2612           Ug(2,1,i-2)=0.0d0
2613           Ug(2,2,i-2)=1.0d0
2614           Ug2(1,1,i-2)=0.0d0
2615           Ug2(1,2,i-2)=0.0d0
2616           Ug2(2,1,i-2)=0.0d0
2617           Ug2(2,2,i-2)=0.0d0
2618         endif
2619         if (i .gt. 3 .and. i .lt. nres+1) then
2620           obrot_der(1,i-2)=-sin1
2621           obrot_der(2,i-2)= cos1
2622           Ugder(1,1,i-2)= sin1
2623           Ugder(1,2,i-2)=-cos1
2624           Ugder(2,1,i-2)=-cos1
2625           Ugder(2,2,i-2)=-sin1
2626           dwacos2=cos2+cos2
2627           dwasin2=sin2+sin2
2628           obrot2_der(1,i-2)=-dwasin2
2629           obrot2_der(2,i-2)= dwacos2
2630           Ug2der(1,1,i-2)= dwasin2
2631           Ug2der(1,2,i-2)=-dwacos2
2632           Ug2der(2,1,i-2)=-dwacos2
2633           Ug2der(2,2,i-2)=-dwasin2
2634         else
2635           obrot_der(1,i-2)=0.0d0
2636           obrot_der(2,i-2)=0.0d0
2637           Ugder(1,1,i-2)=0.0d0
2638           Ugder(1,2,i-2)=0.0d0
2639           Ugder(2,1,i-2)=0.0d0
2640           Ugder(2,2,i-2)=0.0d0
2641           obrot2_der(1,i-2)=0.0d0
2642           obrot2_der(2,i-2)=0.0d0
2643           Ug2der(1,1,i-2)=0.0d0
2644           Ug2der(1,2,i-2)=0.0d0
2645           Ug2der(2,1,i-2)=0.0d0
2646           Ug2der(2,2,i-2)=0.0d0
2647         endif
2648 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2649         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2650           iti = itortyp(itype(i-2))
2651         else
2652           iti=ntortyp+1
2653         endif
2654 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2655         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2656           iti1 = itortyp(itype(i-1))
2657         else
2658           iti1=ntortyp+1
2659         endif
2660 cd        write (iout,*) '*******i',i,' iti1',iti
2661 cd        write (iout,*) 'b1',b1(:,iti)
2662 cd        write (iout,*) 'b2',b2(:,iti)
2663 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2664 c        if (i .gt. iatel_s+2) then
2665         if (i .gt. nnt+2) then
2666           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2667           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2668           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2669      &    then
2670           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2671           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2672           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2673           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2674           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2675           endif
2676         else
2677           do k=1,2
2678             Ub2(k,i-2)=0.0d0
2679             Ctobr(k,i-2)=0.0d0
2680             Dtobr2(k,i-2)=0.0d0
2681             do l=1,2
2682               EUg(l,k,i-2)=0.0d0
2683               CUg(l,k,i-2)=0.0d0
2684               DUg(l,k,i-2)=0.0d0
2685               DtUg2(l,k,i-2)=0.0d0
2686             enddo
2687           enddo
2688         endif
2689         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2690         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2691         do k=1,2
2692           muder(k,i-2)=Ub2der(k,i-2)
2693         enddo
2694 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2695         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2696           iti1 = itortyp(itype(i-1))
2697         else
2698           iti1=ntortyp+1
2699         endif
2700         do k=1,2
2701           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2702         enddo
2703 cd        write (iout,*) 'mu ',mu(:,i-2)
2704 cd        write (iout,*) 'mu1',mu1(:,i-2)
2705 cd        write (iout,*) 'mu2',mu2(:,i-2)
2706         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2707      &  then
2708         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2709         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2710         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2711         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2712         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2713 C Vectors and matrices dependent on a single virtual-bond dihedral.
2714         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2715         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2716         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2717         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2718         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2719         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2720         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2721         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2722         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2723         endif
2724       enddo
2725 C Matrices dependent on two consecutive virtual-bond dihedrals.
2726 C The order of matrices is from left to right.
2727       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2728      &then
2729 c      do i=max0(ivec_start,2),ivec_end
2730       do i=2,nres-1
2731         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2732         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2733         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2734         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2735         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2736         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2737         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2738         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2739       enddo
2740       endif
2741 #if defined(MPI) && defined(PARMAT)
2742 #ifdef DEBUG
2743 c      if (fg_rank.eq.0) then
2744         write (iout,*) "Arrays UG and UGDER before GATHER"
2745         do i=1,nres-1
2746           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2747      &     ((ug(l,k,i),l=1,2),k=1,2),
2748      &     ((ugder(l,k,i),l=1,2),k=1,2)
2749         enddo
2750         write (iout,*) "Arrays UG2 and UG2DER"
2751         do i=1,nres-1
2752           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2753      &     ((ug2(l,k,i),l=1,2),k=1,2),
2754      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2755         enddo
2756         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2757         do i=1,nres-1
2758           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2759      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2760      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2761         enddo
2762         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2763         do i=1,nres-1
2764           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2765      &     costab(i),sintab(i),costab2(i),sintab2(i)
2766         enddo
2767         write (iout,*) "Array MUDER"
2768         do i=1,nres-1
2769           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2770         enddo
2771 c      endif
2772 #endif
2773       if (nfgtasks.gt.1) then
2774         time00=MPI_Wtime()
2775 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2776 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2777 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2778 #ifdef MATGATHER
2779         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2780      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2781      &   FG_COMM1,IERR)
2782         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2783      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2784      &   FG_COMM1,IERR)
2785         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2786      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2787      &   FG_COMM1,IERR)
2788         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2789      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2790      &   FG_COMM1,IERR)
2791         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2792      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2793      &   FG_COMM1,IERR)
2794         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2795      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2796      &   FG_COMM1,IERR)
2797         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2798      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2799      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2800         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2801      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2802      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2803         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2804      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2805      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2806         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2807      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2808      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2809         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2810      &  then
2811         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2812      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2813      &   FG_COMM1,IERR)
2814         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2815      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2816      &   FG_COMM1,IERR)
2817         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2818      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2819      &   FG_COMM1,IERR)
2820        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2821      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2822      &   FG_COMM1,IERR)
2823         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2824      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2825      &   FG_COMM1,IERR)
2826         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2827      &   ivec_count(fg_rank1),
2828      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2829      &   FG_COMM1,IERR)
2830         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2831      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2832      &   FG_COMM1,IERR)
2833         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2834      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2835      &   FG_COMM1,IERR)
2836         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2837      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2838      &   FG_COMM1,IERR)
2839         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2840      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2841      &   FG_COMM1,IERR)
2842         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2843      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2844      &   FG_COMM1,IERR)
2845         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2846      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2847      &   FG_COMM1,IERR)
2848         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2849      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2850      &   FG_COMM1,IERR)
2851         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2852      &   ivec_count(fg_rank1),
2853      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2854      &   FG_COMM1,IERR)
2855         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2856      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2857      &   FG_COMM1,IERR)
2858        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2859      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2860      &   FG_COMM1,IERR)
2861         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2862      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2863      &   FG_COMM1,IERR)
2864        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2865      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2866      &   FG_COMM1,IERR)
2867         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2868      &   ivec_count(fg_rank1),
2869      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2870      &   FG_COMM1,IERR)
2871         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2872      &   ivec_count(fg_rank1),
2873      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2874      &   FG_COMM1,IERR)
2875         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2876      &   ivec_count(fg_rank1),
2877      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2878      &   MPI_MAT2,FG_COMM1,IERR)
2879         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2880      &   ivec_count(fg_rank1),
2881      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2882      &   MPI_MAT2,FG_COMM1,IERR)
2883         endif
2884 #else
2885 c Passes matrix info through the ring
2886       isend=fg_rank1
2887       irecv=fg_rank1-1
2888       if (irecv.lt.0) irecv=nfgtasks1-1
2889       iprev=irecv
2890       inext=fg_rank1+1
2891       if (inext.ge.nfgtasks1) inext=0
2892       do i=1,nfgtasks1-1
2893 c        write (iout,*) "isend",isend," irecv",irecv
2894 c        call flush(iout)
2895         lensend=lentyp(isend)
2896         lenrecv=lentyp(irecv)
2897 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2898 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2899 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2900 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2901 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2902 c        write (iout,*) "Gather ROTAT1"
2903 c        call flush(iout)
2904 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2905 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2906 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2907 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2908 c        write (iout,*) "Gather ROTAT2"
2909 c        call flush(iout)
2910         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2911      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2912      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2913      &   iprev,4400+irecv,FG_COMM,status,IERR)
2914 c        write (iout,*) "Gather ROTAT_OLD"
2915 c        call flush(iout)
2916         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2917      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2918      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2919      &   iprev,5500+irecv,FG_COMM,status,IERR)
2920 c        write (iout,*) "Gather PRECOMP11"
2921 c        call flush(iout)
2922         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2923      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2924      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2925      &   iprev,6600+irecv,FG_COMM,status,IERR)
2926 c        write (iout,*) "Gather PRECOMP12"
2927 c        call flush(iout)
2928         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2929      &  then
2930         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2931      &   MPI_ROTAT2(lensend),inext,7700+isend,
2932      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2933      &   iprev,7700+irecv,FG_COMM,status,IERR)
2934 c        write (iout,*) "Gather PRECOMP21"
2935 c        call flush(iout)
2936         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2937      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2938      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2939      &   iprev,8800+irecv,FG_COMM,status,IERR)
2940 c        write (iout,*) "Gather PRECOMP22"
2941 c        call flush(iout)
2942         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2943      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2944      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2945      &   MPI_PRECOMP23(lenrecv),
2946      &   iprev,9900+irecv,FG_COMM,status,IERR)
2947 c        write (iout,*) "Gather PRECOMP23"
2948 c        call flush(iout)
2949         endif
2950         isend=irecv
2951         irecv=irecv-1
2952         if (irecv.lt.0) irecv=nfgtasks1-1
2953       enddo
2954 #endif
2955         time_gather=time_gather+MPI_Wtime()-time00
2956       endif
2957 #ifdef DEBUG
2958 c      if (fg_rank.eq.0) then
2959         write (iout,*) "Arrays UG and UGDER"
2960         do i=1,nres-1
2961           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2962      &     ((ug(l,k,i),l=1,2),k=1,2),
2963      &     ((ugder(l,k,i),l=1,2),k=1,2)
2964         enddo
2965         write (iout,*) "Arrays UG2 and UG2DER"
2966         do i=1,nres-1
2967           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2968      &     ((ug2(l,k,i),l=1,2),k=1,2),
2969      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2970         enddo
2971         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2972         do i=1,nres-1
2973           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2974      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2975      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2976         enddo
2977         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2978         do i=1,nres-1
2979           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2980      &     costab(i),sintab(i),costab2(i),sintab2(i)
2981         enddo
2982         write (iout,*) "Array MUDER"
2983         do i=1,nres-1
2984           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2985         enddo
2986 c      endif
2987 #endif
2988 #endif
2989 cd      do i=1,nres
2990 cd        iti = itortyp(itype(i))
2991 cd        write (iout,*) i
2992 cd        do j=1,2
2993 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2994 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2995 cd        enddo
2996 cd      enddo
2997       return
2998       end
2999 C--------------------------------------------------------------------------
3000       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3001 C
3002 C This subroutine calculates the average interaction energy and its gradient
3003 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3004 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3005 C The potential depends both on the distance of peptide-group centers and on
3006 C the orientation of the CA-CA virtual bonds.
3007 C
3008       implicit real*8 (a-h,o-z)
3009 #ifdef MPI
3010       include 'mpif.h'
3011 #endif
3012       include 'DIMENSIONS'
3013       include 'COMMON.CONTROL'
3014       include 'COMMON.SETUP'
3015       include 'COMMON.IOUNITS'
3016       include 'COMMON.GEO'
3017       include 'COMMON.VAR'
3018       include 'COMMON.LOCAL'
3019       include 'COMMON.CHAIN'
3020       include 'COMMON.DERIV'
3021       include 'COMMON.INTERACT'
3022       include 'COMMON.CONTACTS'
3023       include 'COMMON.TORSION'
3024       include 'COMMON.VECTORS'
3025       include 'COMMON.FFIELD'
3026       include 'COMMON.TIME1'
3027       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3028      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3029       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3030      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3031       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3032      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3033      &    num_conti,j1,j2
3034 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3035 #ifdef MOMENT
3036       double precision scal_el /1.0d0/
3037 #else
3038       double precision scal_el /0.5d0/
3039 #endif
3040 C 12/13/98
3041 C 13-go grudnia roku pamietnego...
3042       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3043      &                   0.0d0,1.0d0,0.0d0,
3044      &                   0.0d0,0.0d0,1.0d0/
3045 cd      write(iout,*) 'In EELEC'
3046 cd      do i=1,nloctyp
3047 cd        write(iout,*) 'Type',i
3048 cd        write(iout,*) 'B1',B1(:,i)
3049 cd        write(iout,*) 'B2',B2(:,i)
3050 cd        write(iout,*) 'CC',CC(:,:,i)
3051 cd        write(iout,*) 'DD',DD(:,:,i)
3052 cd        write(iout,*) 'EE',EE(:,:,i)
3053 cd      enddo
3054 cd      call check_vecgrad
3055 cd      stop
3056       if (icheckgrad.eq.1) then
3057         do i=1,nres-1
3058           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3059           do k=1,3
3060             dc_norm(k,i)=dc(k,i)*fac
3061           enddo
3062 c          write (iout,*) 'i',i,' fac',fac
3063         enddo
3064       endif
3065       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3066      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3067      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3068 c        call vec_and_deriv
3069 #ifdef TIMING
3070         time01=MPI_Wtime()
3071 #endif
3072         call set_matrices
3073 #ifdef TIMING
3074         time_mat=time_mat+MPI_Wtime()-time01
3075 #endif
3076       endif
3077 cd      do i=1,nres-1
3078 cd        write (iout,*) 'i=',i
3079 cd        do k=1,3
3080 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3081 cd        enddo
3082 cd        do k=1,3
3083 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3084 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3085 cd        enddo
3086 cd      enddo
3087       t_eelecij=0.0d0
3088       ees=0.0D0
3089       evdw1=0.0D0
3090       eel_loc=0.0d0
3091       eello_turn3=0.0d0
3092       eello_turn4=0.0d0
3093       ind=0
3094       do i=1,nres
3095         num_cont_hb(i)=0
3096       enddo
3097 cd      print '(a)','Enter EELEC'
3098 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3099       do i=1,nres
3100         gel_loc_loc(i)=0.0d0
3101         gcorr_loc(i)=0.0d0
3102       enddo
3103 c
3104 c
3105 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3106 C
3107 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3108 C
3109       do i=iturn3_start,iturn3_end
3110         dxi=dc(1,i)
3111         dyi=dc(2,i)
3112         dzi=dc(3,i)
3113         dx_normi=dc_norm(1,i)
3114         dy_normi=dc_norm(2,i)
3115         dz_normi=dc_norm(3,i)
3116         xmedi=c(1,i)+0.5d0*dxi
3117         ymedi=c(2,i)+0.5d0*dyi
3118         zmedi=c(3,i)+0.5d0*dzi
3119         num_conti=0
3120         call eelecij(i,i+2,ees,evdw1,eel_loc)
3121         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3122         num_cont_hb(i)=num_conti
3123       enddo
3124       do i=iturn4_start,iturn4_end
3125         dxi=dc(1,i)
3126         dyi=dc(2,i)
3127         dzi=dc(3,i)
3128         dx_normi=dc_norm(1,i)
3129         dy_normi=dc_norm(2,i)
3130         dz_normi=dc_norm(3,i)
3131         xmedi=c(1,i)+0.5d0*dxi
3132         ymedi=c(2,i)+0.5d0*dyi
3133         zmedi=c(3,i)+0.5d0*dzi
3134         num_conti=num_cont_hb(i)
3135         call eelecij(i,i+3,ees,evdw1,eel_loc)
3136         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3137         num_cont_hb(i)=num_conti
3138       enddo   ! i
3139 c
3140 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3141 c
3142       do i=iatel_s,iatel_e
3143         dxi=dc(1,i)
3144         dyi=dc(2,i)
3145         dzi=dc(3,i)
3146         dx_normi=dc_norm(1,i)
3147         dy_normi=dc_norm(2,i)
3148         dz_normi=dc_norm(3,i)
3149         xmedi=c(1,i)+0.5d0*dxi
3150         ymedi=c(2,i)+0.5d0*dyi
3151         zmedi=c(3,i)+0.5d0*dzi
3152 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3153         num_conti=num_cont_hb(i)
3154         do j=ielstart(i),ielend(i)
3155           call eelecij(i,j,ees,evdw1,eel_loc)
3156         enddo ! j
3157         num_cont_hb(i)=num_conti
3158       enddo   ! i
3159 c      write (iout,*) "Number of loop steps in EELEC:",ind
3160 cd      do i=1,nres
3161 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3162 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3163 cd      enddo
3164 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3165 ccc      eel_loc=eel_loc+eello_turn3
3166 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3167       return
3168       end
3169 C-------------------------------------------------------------------------------
3170       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3171       implicit real*8 (a-h,o-z)
3172       include 'DIMENSIONS'
3173 #ifdef MPI
3174       include "mpif.h"
3175 #endif
3176       include 'COMMON.CONTROL'
3177       include 'COMMON.IOUNITS'
3178       include 'COMMON.GEO'
3179       include 'COMMON.VAR'
3180       include 'COMMON.LOCAL'
3181       include 'COMMON.CHAIN'
3182       include 'COMMON.DERIV'
3183       include 'COMMON.INTERACT'
3184       include 'COMMON.CONTACTS'
3185       include 'COMMON.TORSION'
3186       include 'COMMON.VECTORS'
3187       include 'COMMON.FFIELD'
3188       include 'COMMON.TIME1'
3189       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3190      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3191       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3192      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3193       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3194      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3195      &    num_conti,j1,j2
3196 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3197 #ifdef MOMENT
3198       double precision scal_el /1.0d0/
3199 #else
3200       double precision scal_el /0.5d0/
3201 #endif
3202 C 12/13/98
3203 C 13-go grudnia roku pamietnego...
3204       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3205      &                   0.0d0,1.0d0,0.0d0,
3206      &                   0.0d0,0.0d0,1.0d0/
3207 c          time00=MPI_Wtime()
3208 cd      write (iout,*) "eelecij",i,j
3209 c          ind=ind+1
3210           iteli=itel(i)
3211           itelj=itel(j)
3212           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3213           aaa=app(iteli,itelj)
3214           bbb=bpp(iteli,itelj)
3215           ael6i=ael6(iteli,itelj)
3216           ael3i=ael3(iteli,itelj)
3217           dxj=dc(1,j)
3218           dyj=dc(2,j)
3219           dzj=dc(3,j)
3220           dx_normj=dc_norm(1,j)
3221           dy_normj=dc_norm(2,j)
3222           dz_normj=dc_norm(3,j)
3223           xj=c(1,j)+0.5D0*dxj-xmedi
3224           yj=c(2,j)+0.5D0*dyj-ymedi
3225           zj=c(3,j)+0.5D0*dzj-zmedi
3226           rij=xj*xj+yj*yj+zj*zj
3227           rrmij=1.0D0/rij
3228           rij=dsqrt(rij)
3229           rmij=1.0D0/rij
3230           r3ij=rrmij*rmij
3231           r6ij=r3ij*r3ij
3232           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3233           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3234           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3235           fac=cosa-3.0D0*cosb*cosg
3236           ev1=aaa*r6ij*r6ij
3237 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3238           if (j.eq.i+2) ev1=scal_el*ev1
3239           ev2=bbb*r6ij
3240           fac3=ael6i*r6ij
3241           fac4=ael3i*r3ij
3242           evdwij=ev1+ev2
3243           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3244           el2=fac4*fac
3245           eesij=el1+el2
3246 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3247           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3248           ees=ees+eesij
3249           evdw1=evdw1+evdwij
3250 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3251 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3252 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3253 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3254
3255           if (energy_dec) then
3256               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3257               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3258           endif
3259
3260 C
3261 C Calculate contributions to the Cartesian gradient.
3262 C
3263 #ifdef SPLITELE
3264           facvdw=-6*rrmij*(ev1+evdwij)
3265           facel=-3*rrmij*(el1+eesij)
3266           fac1=fac
3267           erij(1)=xj*rmij
3268           erij(2)=yj*rmij
3269           erij(3)=zj*rmij
3270 *
3271 * Radial derivatives. First process both termini of the fragment (i,j)
3272 *
3273           ggg(1)=facel*xj
3274           ggg(2)=facel*yj
3275           ggg(3)=facel*zj
3276 c          do k=1,3
3277 c            ghalf=0.5D0*ggg(k)
3278 c            gelc(k,i)=gelc(k,i)+ghalf
3279 c            gelc(k,j)=gelc(k,j)+ghalf
3280 c          enddo
3281 c 9/28/08 AL Gradient compotents will be summed only at the end
3282           do k=1,3
3283             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3284             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3285           enddo
3286 *
3287 * Loop over residues i+1 thru j-1.
3288 *
3289 cgrad          do k=i+1,j-1
3290 cgrad            do l=1,3
3291 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3292 cgrad            enddo
3293 cgrad          enddo
3294           ggg(1)=facvdw*xj
3295           ggg(2)=facvdw*yj
3296           ggg(3)=facvdw*zj
3297 c          do k=1,3
3298 c            ghalf=0.5D0*ggg(k)
3299 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3300 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3301 c          enddo
3302 c 9/28/08 AL Gradient compotents will be summed only at the end
3303           do k=1,3
3304             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3305             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3306           enddo
3307 *
3308 * Loop over residues i+1 thru j-1.
3309 *
3310 cgrad          do k=i+1,j-1
3311 cgrad            do l=1,3
3312 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3313 cgrad            enddo
3314 cgrad          enddo
3315 #else
3316           facvdw=ev1+evdwij
3317           facel=el1+eesij
3318           fac1=fac
3319           fac=-3*rrmij*(facvdw+facvdw+facel)
3320           erij(1)=xj*rmij
3321           erij(2)=yj*rmij
3322           erij(3)=zj*rmij
3323 *
3324 * Radial derivatives. First process both termini of the fragment (i,j)
3325 *
3326           ggg(1)=fac*xj
3327           ggg(2)=fac*yj
3328           ggg(3)=fac*zj
3329 c          do k=1,3
3330 c            ghalf=0.5D0*ggg(k)
3331 c            gelc(k,i)=gelc(k,i)+ghalf
3332 c            gelc(k,j)=gelc(k,j)+ghalf
3333 c          enddo
3334 c 9/28/08 AL Gradient compotents will be summed only at the end
3335           do k=1,3
3336             gelc_long(k,j)=gelc(k,j)+ggg(k)
3337             gelc_long(k,i)=gelc(k,i)-ggg(k)
3338           enddo
3339 *
3340 * Loop over residues i+1 thru j-1.
3341 *
3342 cgrad          do k=i+1,j-1
3343 cgrad            do l=1,3
3344 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3345 cgrad            enddo
3346 cgrad          enddo
3347 c 9/28/08 AL Gradient compotents will be summed only at the end
3348           ggg(1)=facvdw*xj
3349           ggg(2)=facvdw*yj
3350           ggg(3)=facvdw*zj
3351           do k=1,3
3352             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3353             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3354           enddo
3355 #endif
3356 *
3357 * Angular part
3358 *
3359           ecosa=2.0D0*fac3*fac1+fac4
3360           fac4=-3.0D0*fac4
3361           fac3=-6.0D0*fac3
3362           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3363           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3364           do k=1,3
3365             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3366             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3367           enddo
3368 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3369 cd   &          (dcosg(k),k=1,3)
3370           do k=1,3
3371             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3372           enddo
3373 c          do k=1,3
3374 c            ghalf=0.5D0*ggg(k)
3375 c            gelc(k,i)=gelc(k,i)+ghalf
3376 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3377 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3378 c            gelc(k,j)=gelc(k,j)+ghalf
3379 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3380 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3381 c          enddo
3382 cgrad          do k=i+1,j-1
3383 cgrad            do l=1,3
3384 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3385 cgrad            enddo
3386 cgrad          enddo
3387           do k=1,3
3388             gelc(k,i)=gelc(k,i)
3389      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3390      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3391             gelc(k,j)=gelc(k,j)
3392      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3393      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3394             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3395             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3396           enddo
3397           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3398      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3399      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3400 C
3401 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3402 C   energy of a peptide unit is assumed in the form of a second-order
3403 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3404 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3405 C   are computed for EVERY pair of non-contiguous peptide groups.
3406 C
3407           if (j.lt.nres-1) then
3408             j1=j+1
3409             j2=j-1
3410           else
3411             j1=j-1
3412             j2=j-2
3413           endif
3414           kkk=0
3415           do k=1,2
3416             do l=1,2
3417               kkk=kkk+1
3418               muij(kkk)=mu(k,i)*mu(l,j)
3419             enddo
3420           enddo
3421 cd         write (iout,*) 'EELEC: i',i,' j',j
3422 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3423 cd          write(iout,*) 'muij',muij
3424           ury=scalar(uy(1,i),erij)
3425           urz=scalar(uz(1,i),erij)
3426           vry=scalar(uy(1,j),erij)
3427           vrz=scalar(uz(1,j),erij)
3428           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3429           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3430           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3431           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3432           fac=dsqrt(-ael6i)*r3ij
3433           a22=a22*fac
3434           a23=a23*fac
3435           a32=a32*fac
3436           a33=a33*fac
3437 cd          write (iout,'(4i5,4f10.5)')
3438 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3439 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3440 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3441 cd     &      uy(:,j),uz(:,j)
3442 cd          write (iout,'(4f10.5)')
3443 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3444 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3445 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3446 cd           write (iout,'(9f10.5/)')
3447 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3448 C Derivatives of the elements of A in virtual-bond vectors
3449           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3450           do k=1,3
3451             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3452             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3453             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3454             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3455             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3456             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3457             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3458             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3459             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3460             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3461             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3462             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3463           enddo
3464 C Compute radial contributions to the gradient
3465           facr=-3.0d0*rrmij
3466           a22der=a22*facr
3467           a23der=a23*facr
3468           a32der=a32*facr
3469           a33der=a33*facr
3470           agg(1,1)=a22der*xj
3471           agg(2,1)=a22der*yj
3472           agg(3,1)=a22der*zj
3473           agg(1,2)=a23der*xj
3474           agg(2,2)=a23der*yj
3475           agg(3,2)=a23der*zj
3476           agg(1,3)=a32der*xj
3477           agg(2,3)=a32der*yj
3478           agg(3,3)=a32der*zj
3479           agg(1,4)=a33der*xj
3480           agg(2,4)=a33der*yj
3481           agg(3,4)=a33der*zj
3482 C Add the contributions coming from er
3483           fac3=-3.0d0*fac
3484           do k=1,3
3485             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3486             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3487             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3488             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3489           enddo
3490           do k=1,3
3491 C Derivatives in DC(i)
3492 cgrad            ghalf1=0.5d0*agg(k,1)
3493 cgrad            ghalf2=0.5d0*agg(k,2)
3494 cgrad            ghalf3=0.5d0*agg(k,3)
3495 cgrad            ghalf4=0.5d0*agg(k,4)
3496             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3497      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3498             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3499      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3500             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3501      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3502             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3503      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3504 C Derivatives in DC(i+1)
3505             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3506      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3507             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3508      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3509             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3510      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3511             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3512      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3513 C Derivatives in DC(j)
3514             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3515      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3516             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3517      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3518             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3519      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3520             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3521      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3522 C Derivatives in DC(j+1) or DC(nres-1)
3523             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3524      &      -3.0d0*vryg(k,3)*ury)
3525             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3526      &      -3.0d0*vrzg(k,3)*ury)
3527             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3528      &      -3.0d0*vryg(k,3)*urz)
3529             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3530      &      -3.0d0*vrzg(k,3)*urz)
3531 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3532 cgrad              do l=1,4
3533 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3534 cgrad              enddo
3535 cgrad            endif
3536           enddo
3537           acipa(1,1)=a22
3538           acipa(1,2)=a23
3539           acipa(2,1)=a32
3540           acipa(2,2)=a33
3541           a22=-a22
3542           a23=-a23
3543           do l=1,2
3544             do k=1,3
3545               agg(k,l)=-agg(k,l)
3546               aggi(k,l)=-aggi(k,l)
3547               aggi1(k,l)=-aggi1(k,l)
3548               aggj(k,l)=-aggj(k,l)
3549               aggj1(k,l)=-aggj1(k,l)
3550             enddo
3551           enddo
3552           if (j.lt.nres-1) then
3553             a22=-a22
3554             a32=-a32
3555             do l=1,3,2
3556               do k=1,3
3557                 agg(k,l)=-agg(k,l)
3558                 aggi(k,l)=-aggi(k,l)
3559                 aggi1(k,l)=-aggi1(k,l)
3560                 aggj(k,l)=-aggj(k,l)
3561                 aggj1(k,l)=-aggj1(k,l)
3562               enddo
3563             enddo
3564           else
3565             a22=-a22
3566             a23=-a23
3567             a32=-a32
3568             a33=-a33
3569             do l=1,4
3570               do k=1,3
3571                 agg(k,l)=-agg(k,l)
3572                 aggi(k,l)=-aggi(k,l)
3573                 aggi1(k,l)=-aggi1(k,l)
3574                 aggj(k,l)=-aggj(k,l)
3575                 aggj1(k,l)=-aggj1(k,l)
3576               enddo
3577             enddo
3578           endif
3579           ENDIF ! WCORR
3580           IF (wel_loc.gt.0.0d0) THEN
3581 C Contribution to the local-electrostatic energy coming from the i-j pair
3582           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3583      &     +a33*muij(4)
3584 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3585
3586           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3587      &            'eelloc',i,j,eel_loc_ij
3588
3589           eel_loc=eel_loc+eel_loc_ij
3590 C Partial derivatives in virtual-bond dihedral angles gamma
3591           if (i.gt.1)
3592      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3593      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3594      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3595           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3596      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3597      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3598 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3599           do l=1,3
3600             ggg(l)=agg(l,1)*muij(1)+
3601      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3602             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3603             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3604 cgrad            ghalf=0.5d0*ggg(l)
3605 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3606 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3607           enddo
3608 cgrad          do k=i+1,j2
3609 cgrad            do l=1,3
3610 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3611 cgrad            enddo
3612 cgrad          enddo
3613 C Remaining derivatives of eello
3614           do l=1,3
3615             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3616      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3617             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3618      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3619             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3620      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3621             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3622      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3623           enddo
3624           ENDIF
3625 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3626 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3627           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3628      &       .and. num_conti.le.maxconts) then
3629 c            write (iout,*) i,j," entered corr"
3630 C
3631 C Calculate the contact function. The ith column of the array JCONT will
3632 C contain the numbers of atoms that make contacts with the atom I (of numbers
3633 C greater than I). The arrays FACONT and GACONT will contain the values of
3634 C the contact function and its derivative.
3635 c           r0ij=1.02D0*rpp(iteli,itelj)
3636 c           r0ij=1.11D0*rpp(iteli,itelj)
3637             r0ij=2.20D0*rpp(iteli,itelj)
3638 c           r0ij=1.55D0*rpp(iteli,itelj)
3639             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3640             if (fcont.gt.0.0D0) then
3641               num_conti=num_conti+1
3642               if (num_conti.gt.maxconts) then
3643                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3644      &                         ' will skip next contacts for this conf.'
3645               else
3646                 jcont_hb(num_conti,i)=j
3647 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3648 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3649                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3650      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3651 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3652 C  terms.
3653                 d_cont(num_conti,i)=rij
3654 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3655 C     --- Electrostatic-interaction matrix ---
3656                 a_chuj(1,1,num_conti,i)=a22
3657                 a_chuj(1,2,num_conti,i)=a23
3658                 a_chuj(2,1,num_conti,i)=a32
3659                 a_chuj(2,2,num_conti,i)=a33
3660 C     --- Gradient of rij
3661                 do kkk=1,3
3662                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3663                 enddo
3664                 kkll=0
3665                 do k=1,2
3666                   do l=1,2
3667                     kkll=kkll+1
3668                     do m=1,3
3669                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3670                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3671                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3672                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3673                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3674                     enddo
3675                   enddo
3676                 enddo
3677                 ENDIF
3678                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3679 C Calculate contact energies
3680                 cosa4=4.0D0*cosa
3681                 wij=cosa-3.0D0*cosb*cosg
3682                 cosbg1=cosb+cosg
3683                 cosbg2=cosb-cosg
3684 c               fac3=dsqrt(-ael6i)/r0ij**3
3685                 fac3=dsqrt(-ael6i)*r3ij
3686 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3687                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3688                 if (ees0tmp.gt.0) then
3689                   ees0pij=dsqrt(ees0tmp)
3690                 else
3691                   ees0pij=0
3692                 endif
3693 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3694                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3695                 if (ees0tmp.gt.0) then
3696                   ees0mij=dsqrt(ees0tmp)
3697                 else
3698                   ees0mij=0
3699                 endif
3700 c               ees0mij=0.0D0
3701                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3702                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3703 C Diagnostics. Comment out or remove after debugging!
3704 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3705 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3706 c               ees0m(num_conti,i)=0.0D0
3707 C End diagnostics.
3708 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3709 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3710 C Angular derivatives of the contact function
3711                 ees0pij1=fac3/ees0pij
3712                 ees0mij1=fac3/ees0mij
3713                 fac3p=-3.0D0*fac3*rrmij
3714                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3715                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3716 c               ees0mij1=0.0D0
3717                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3718                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3719                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3720                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3721                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3722                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3723                 ecosap=ecosa1+ecosa2
3724                 ecosbp=ecosb1+ecosb2
3725                 ecosgp=ecosg1+ecosg2
3726                 ecosam=ecosa1-ecosa2
3727                 ecosbm=ecosb1-ecosb2
3728                 ecosgm=ecosg1-ecosg2
3729 C Diagnostics
3730 c               ecosap=ecosa1
3731 c               ecosbp=ecosb1
3732 c               ecosgp=ecosg1
3733 c               ecosam=0.0D0
3734 c               ecosbm=0.0D0
3735 c               ecosgm=0.0D0
3736 C End diagnostics
3737                 facont_hb(num_conti,i)=fcont
3738                 fprimcont=fprimcont/rij
3739 cd              facont_hb(num_conti,i)=1.0D0
3740 C Following line is for diagnostics.
3741 cd              fprimcont=0.0D0
3742                 do k=1,3
3743                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3744                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3745                 enddo
3746                 do k=1,3
3747                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3748                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3749                 enddo
3750                 gggp(1)=gggp(1)+ees0pijp*xj
3751                 gggp(2)=gggp(2)+ees0pijp*yj
3752                 gggp(3)=gggp(3)+ees0pijp*zj
3753                 gggm(1)=gggm(1)+ees0mijp*xj
3754                 gggm(2)=gggm(2)+ees0mijp*yj
3755                 gggm(3)=gggm(3)+ees0mijp*zj
3756 C Derivatives due to the contact function
3757                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3758                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3759                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3760                 do k=1,3
3761 c
3762 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3763 c          following the change of gradient-summation algorithm.
3764 c
3765 cgrad                  ghalfp=0.5D0*gggp(k)
3766 cgrad                  ghalfm=0.5D0*gggm(k)
3767                   gacontp_hb1(k,num_conti,i)=!ghalfp
3768      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3769      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3770                   gacontp_hb2(k,num_conti,i)=!ghalfp
3771      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3772      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3773                   gacontp_hb3(k,num_conti,i)=gggp(k)
3774                   gacontm_hb1(k,num_conti,i)=!ghalfm
3775      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3776      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3777                   gacontm_hb2(k,num_conti,i)=!ghalfm
3778      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3779      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3780                   gacontm_hb3(k,num_conti,i)=gggm(k)
3781                 enddo
3782 C Diagnostics. Comment out or remove after debugging!
3783 cdiag           do k=1,3
3784 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3785 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3786 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3787 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3788 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3789 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3790 cdiag           enddo
3791               ENDIF ! wcorr
3792               endif  ! num_conti.le.maxconts
3793             endif  ! fcont.gt.0
3794           endif    ! j.gt.i+1
3795           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3796             do k=1,4
3797               do l=1,3
3798                 ghalf=0.5d0*agg(l,k)
3799                 aggi(l,k)=aggi(l,k)+ghalf
3800                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3801                 aggj(l,k)=aggj(l,k)+ghalf
3802               enddo
3803             enddo
3804             if (j.eq.nres-1 .and. i.lt.j-2) then
3805               do k=1,4
3806                 do l=1,3
3807                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3808                 enddo
3809               enddo
3810             endif
3811           endif
3812 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3813       return
3814       end
3815 C-----------------------------------------------------------------------------
3816       subroutine eturn3(i,eello_turn3)
3817 C Third- and fourth-order contributions from turns
3818       implicit real*8 (a-h,o-z)
3819       include 'DIMENSIONS'
3820       include 'COMMON.IOUNITS'
3821       include 'COMMON.GEO'
3822       include 'COMMON.VAR'
3823       include 'COMMON.LOCAL'
3824       include 'COMMON.CHAIN'
3825       include 'COMMON.DERIV'
3826       include 'COMMON.INTERACT'
3827       include 'COMMON.CONTACTS'
3828       include 'COMMON.TORSION'
3829       include 'COMMON.VECTORS'
3830       include 'COMMON.FFIELD'
3831       include 'COMMON.CONTROL'
3832       dimension ggg(3)
3833       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3834      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3835      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3836       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3837      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3838       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3839      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3840      &    num_conti,j1,j2
3841       j=i+2
3842 c      write (iout,*) "eturn3",i,j,j1,j2
3843       a_temp(1,1)=a22
3844       a_temp(1,2)=a23
3845       a_temp(2,1)=a32
3846       a_temp(2,2)=a33
3847 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3848 C
3849 C               Third-order contributions
3850 C
3851 C                 (i+2)o----(i+3)
3852 C                      | |
3853 C                      | |
3854 C                 (i+1)o----i
3855 C
3856 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3857 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3858         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3859         call transpose2(auxmat(1,1),auxmat1(1,1))
3860         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3861         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3862         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3863      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3864 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3865 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3866 cd     &    ' eello_turn3_num',4*eello_turn3_num
3867 C Derivatives in gamma(i)
3868         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3869         call transpose2(auxmat2(1,1),auxmat3(1,1))
3870         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3871         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3872 C Derivatives in gamma(i+1)
3873         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3874         call transpose2(auxmat2(1,1),auxmat3(1,1))
3875         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3876         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3877      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3878 C Cartesian derivatives
3879         do l=1,3
3880 c            ghalf1=0.5d0*agg(l,1)
3881 c            ghalf2=0.5d0*agg(l,2)
3882 c            ghalf3=0.5d0*agg(l,3)
3883 c            ghalf4=0.5d0*agg(l,4)
3884           a_temp(1,1)=aggi(l,1)!+ghalf1
3885           a_temp(1,2)=aggi(l,2)!+ghalf2
3886           a_temp(2,1)=aggi(l,3)!+ghalf3
3887           a_temp(2,2)=aggi(l,4)!+ghalf4
3888           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3889           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3890      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3891           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3892           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3893           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3894           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3895           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3896           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3897      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3898           a_temp(1,1)=aggj(l,1)!+ghalf1
3899           a_temp(1,2)=aggj(l,2)!+ghalf2
3900           a_temp(2,1)=aggj(l,3)!+ghalf3
3901           a_temp(2,2)=aggj(l,4)!+ghalf4
3902           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3903           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3904      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3905           a_temp(1,1)=aggj1(l,1)
3906           a_temp(1,2)=aggj1(l,2)
3907           a_temp(2,1)=aggj1(l,3)
3908           a_temp(2,2)=aggj1(l,4)
3909           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3910           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3911      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3912         enddo
3913       return
3914       end
3915 C-------------------------------------------------------------------------------
3916       subroutine eturn4(i,eello_turn4)
3917 C Third- and fourth-order contributions from turns
3918       implicit real*8 (a-h,o-z)
3919       include 'DIMENSIONS'
3920       include 'COMMON.IOUNITS'
3921       include 'COMMON.GEO'
3922       include 'COMMON.VAR'
3923       include 'COMMON.LOCAL'
3924       include 'COMMON.CHAIN'
3925       include 'COMMON.DERIV'
3926       include 'COMMON.INTERACT'
3927       include 'COMMON.CONTACTS'
3928       include 'COMMON.TORSION'
3929       include 'COMMON.VECTORS'
3930       include 'COMMON.FFIELD'
3931       include 'COMMON.CONTROL'
3932       dimension ggg(3)
3933       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3934      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3935      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3936       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3937      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3938       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3939      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3940      &    num_conti,j1,j2
3941       j=i+3
3942 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3943 C
3944 C               Fourth-order contributions
3945 C
3946 C                 (i+3)o----(i+4)
3947 C                     /  |
3948 C               (i+2)o   |
3949 C                     \  |
3950 C                 (i+1)o----i
3951 C
3952 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3953 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3954 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3955         a_temp(1,1)=a22
3956         a_temp(1,2)=a23
3957         a_temp(2,1)=a32
3958         a_temp(2,2)=a33
3959         iti1=itortyp(itype(i+1))
3960         iti2=itortyp(itype(i+2))
3961         iti3=itortyp(itype(i+3))
3962 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3963         call transpose2(EUg(1,1,i+1),e1t(1,1))
3964         call transpose2(Eug(1,1,i+2),e2t(1,1))
3965         call transpose2(Eug(1,1,i+3),e3t(1,1))
3966         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3967         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3968         s1=scalar2(b1(1,iti2),auxvec(1))
3969         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3970         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3971         s2=scalar2(b1(1,iti1),auxvec(1))
3972         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3973         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3974         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3975         eello_turn4=eello_turn4-(s1+s2+s3)
3976         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3977      &      'eturn4',i,j,-(s1+s2+s3)
3978 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3979 cd     &    ' eello_turn4_num',8*eello_turn4_num
3980 C Derivatives in gamma(i)
3981         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3982         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3983         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3984         s1=scalar2(b1(1,iti2),auxvec(1))
3985         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3986         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3987         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3988 C Derivatives in gamma(i+1)
3989         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3990         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3991         s2=scalar2(b1(1,iti1),auxvec(1))
3992         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3993         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3994         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3995         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3996 C Derivatives in gamma(i+2)
3997         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3998         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3999         s1=scalar2(b1(1,iti2),auxvec(1))
4000         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4001         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4002         s2=scalar2(b1(1,iti1),auxvec(1))
4003         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4004         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4005         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4006         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4007 C Cartesian derivatives
4008 C Derivatives of this turn contributions in DC(i+2)
4009         if (j.lt.nres-1) then
4010           do l=1,3
4011             a_temp(1,1)=agg(l,1)
4012             a_temp(1,2)=agg(l,2)
4013             a_temp(2,1)=agg(l,3)
4014             a_temp(2,2)=agg(l,4)
4015             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4016             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4017             s1=scalar2(b1(1,iti2),auxvec(1))
4018             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4019             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4020             s2=scalar2(b1(1,iti1),auxvec(1))
4021             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4022             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4023             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4024             ggg(l)=-(s1+s2+s3)
4025             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4026           enddo
4027         endif
4028 C Remaining derivatives of this turn contribution
4029         do l=1,3
4030           a_temp(1,1)=aggi(l,1)
4031           a_temp(1,2)=aggi(l,2)
4032           a_temp(2,1)=aggi(l,3)
4033           a_temp(2,2)=aggi(l,4)
4034           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4035           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4036           s1=scalar2(b1(1,iti2),auxvec(1))
4037           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4038           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4039           s2=scalar2(b1(1,iti1),auxvec(1))
4040           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4041           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4042           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4043           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4044           a_temp(1,1)=aggi1(l,1)
4045           a_temp(1,2)=aggi1(l,2)
4046           a_temp(2,1)=aggi1(l,3)
4047           a_temp(2,2)=aggi1(l,4)
4048           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4049           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4050           s1=scalar2(b1(1,iti2),auxvec(1))
4051           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4052           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4053           s2=scalar2(b1(1,iti1),auxvec(1))
4054           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4055           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4056           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4057           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4058           a_temp(1,1)=aggj(l,1)
4059           a_temp(1,2)=aggj(l,2)
4060           a_temp(2,1)=aggj(l,3)
4061           a_temp(2,2)=aggj(l,4)
4062           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4063           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4064           s1=scalar2(b1(1,iti2),auxvec(1))
4065           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4066           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4067           s2=scalar2(b1(1,iti1),auxvec(1))
4068           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4069           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4070           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4071           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4072           a_temp(1,1)=aggj1(l,1)
4073           a_temp(1,2)=aggj1(l,2)
4074           a_temp(2,1)=aggj1(l,3)
4075           a_temp(2,2)=aggj1(l,4)
4076           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4077           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4078           s1=scalar2(b1(1,iti2),auxvec(1))
4079           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4080           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4081           s2=scalar2(b1(1,iti1),auxvec(1))
4082           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4083           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4084           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4085 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4086           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4087         enddo
4088       return
4089       end
4090 C-----------------------------------------------------------------------------
4091       subroutine vecpr(u,v,w)
4092       implicit real*8(a-h,o-z)
4093       dimension u(3),v(3),w(3)
4094       w(1)=u(2)*v(3)-u(3)*v(2)
4095       w(2)=-u(1)*v(3)+u(3)*v(1)
4096       w(3)=u(1)*v(2)-u(2)*v(1)
4097       return
4098       end
4099 C-----------------------------------------------------------------------------
4100       subroutine unormderiv(u,ugrad,unorm,ungrad)
4101 C This subroutine computes the derivatives of a normalized vector u, given
4102 C the derivatives computed without normalization conditions, ugrad. Returns
4103 C ungrad.
4104       implicit none
4105       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4106       double precision vec(3)
4107       double precision scalar
4108       integer i,j
4109 c      write (2,*) 'ugrad',ugrad
4110 c      write (2,*) 'u',u
4111       do i=1,3
4112         vec(i)=scalar(ugrad(1,i),u(1))
4113       enddo
4114 c      write (2,*) 'vec',vec
4115       do i=1,3
4116         do j=1,3
4117           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4118         enddo
4119       enddo
4120 c      write (2,*) 'ungrad',ungrad
4121       return
4122       end
4123 C-----------------------------------------------------------------------------
4124       subroutine escp_soft_sphere(evdw2,evdw2_14)
4125 C
4126 C This subroutine calculates the excluded-volume interaction energy between
4127 C peptide-group centers and side chains and its gradient in virtual-bond and
4128 C side-chain vectors.
4129 C
4130       implicit real*8 (a-h,o-z)
4131       include 'DIMENSIONS'
4132       include 'COMMON.GEO'
4133       include 'COMMON.VAR'
4134       include 'COMMON.LOCAL'
4135       include 'COMMON.CHAIN'
4136       include 'COMMON.DERIV'
4137       include 'COMMON.INTERACT'
4138       include 'COMMON.FFIELD'
4139       include 'COMMON.IOUNITS'
4140       include 'COMMON.CONTROL'
4141       dimension ggg(3)
4142       evdw2=0.0D0
4143       evdw2_14=0.0d0
4144       r0_scp=4.5d0
4145 cd    print '(a)','Enter ESCP'
4146 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4147       do i=iatscp_s,iatscp_e
4148         iteli=itel(i)
4149         xi=0.5D0*(c(1,i)+c(1,i+1))
4150         yi=0.5D0*(c(2,i)+c(2,i+1))
4151         zi=0.5D0*(c(3,i)+c(3,i+1))
4152
4153         do iint=1,nscp_gr(i)
4154
4155         do j=iscpstart(i,iint),iscpend(i,iint)
4156           itypj=itype(j)
4157 C Uncomment following three lines for SC-p interactions
4158 c         xj=c(1,nres+j)-xi
4159 c         yj=c(2,nres+j)-yi
4160 c         zj=c(3,nres+j)-zi
4161 C Uncomment following three lines for Ca-p interactions
4162           xj=c(1,j)-xi
4163           yj=c(2,j)-yi
4164           zj=c(3,j)-zi
4165           rij=xj*xj+yj*yj+zj*zj
4166           r0ij=r0_scp
4167           r0ijsq=r0ij*r0ij
4168           if (rij.lt.r0ijsq) then
4169             evdwij=0.25d0*(rij-r0ijsq)**2
4170             fac=rij-r0ijsq
4171           else
4172             evdwij=0.0d0
4173             fac=0.0d0
4174           endif
4175           evdw2=evdw2+evdwij
4176 C
4177 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4178 C
4179           ggg(1)=xj*fac
4180           ggg(2)=yj*fac
4181           ggg(3)=zj*fac
4182 cgrad          if (j.lt.i) then
4183 cd          write (iout,*) 'j<i'
4184 C Uncomment following three lines for SC-p interactions
4185 c           do k=1,3
4186 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4187 c           enddo
4188 cgrad          else
4189 cd          write (iout,*) 'j>i'
4190 cgrad            do k=1,3
4191 cgrad              ggg(k)=-ggg(k)
4192 C Uncomment following line for SC-p interactions
4193 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4194 cgrad            enddo
4195 cgrad          endif
4196 cgrad          do k=1,3
4197 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4198 cgrad          enddo
4199 cgrad          kstart=min0(i+1,j)
4200 cgrad          kend=max0(i-1,j-1)
4201 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4202 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4203 cgrad          do k=kstart,kend
4204 cgrad            do l=1,3
4205 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4206 cgrad            enddo
4207 cgrad          enddo
4208           do k=1,3
4209             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4210             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4211           enddo
4212         enddo
4213
4214         enddo ! iint
4215       enddo ! i
4216       return
4217       end
4218 C-----------------------------------------------------------------------------
4219       subroutine escp(evdw2,evdw2_14)
4220 C
4221 C This subroutine calculates the excluded-volume interaction energy between
4222 C peptide-group centers and side chains and its gradient in virtual-bond and
4223 C side-chain vectors.
4224 C
4225       implicit real*8 (a-h,o-z)
4226       include 'DIMENSIONS'
4227       include 'COMMON.GEO'
4228       include 'COMMON.VAR'
4229       include 'COMMON.LOCAL'
4230       include 'COMMON.CHAIN'
4231       include 'COMMON.DERIV'
4232       include 'COMMON.INTERACT'
4233       include 'COMMON.FFIELD'
4234       include 'COMMON.IOUNITS'
4235       include 'COMMON.CONTROL'
4236       dimension ggg(3)
4237       evdw2=0.0D0
4238       evdw2_14=0.0d0
4239 cd    print '(a)','Enter ESCP'
4240 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4241       do i=iatscp_s,iatscp_e
4242         iteli=itel(i)
4243         xi=0.5D0*(c(1,i)+c(1,i+1))
4244         yi=0.5D0*(c(2,i)+c(2,i+1))
4245         zi=0.5D0*(c(3,i)+c(3,i+1))
4246
4247         do iint=1,nscp_gr(i)
4248
4249         do j=iscpstart(i,iint),iscpend(i,iint)
4250           itypj=itype(j)
4251 C Uncomment following three lines for SC-p interactions
4252 c         xj=c(1,nres+j)-xi
4253 c         yj=c(2,nres+j)-yi
4254 c         zj=c(3,nres+j)-zi
4255 C Uncomment following three lines for Ca-p interactions
4256           xj=c(1,j)-xi
4257           yj=c(2,j)-yi
4258           zj=c(3,j)-zi
4259           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4260           fac=rrij**expon2
4261           e1=fac*fac*aad(itypj,iteli)
4262           e2=fac*bad(itypj,iteli)
4263           if (iabs(j-i) .le. 2) then
4264             e1=scal14*e1
4265             e2=scal14*e2
4266             evdw2_14=evdw2_14+e1+e2
4267           endif
4268           evdwij=e1+e2
4269           evdw2=evdw2+evdwij
4270           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4271      &        'evdw2',i,j,evdwij
4272 C
4273 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4274 C
4275           fac=-(evdwij+e1)*rrij
4276           ggg(1)=xj*fac
4277           ggg(2)=yj*fac
4278           ggg(3)=zj*fac
4279 cgrad          if (j.lt.i) then
4280 cd          write (iout,*) 'j<i'
4281 C Uncomment following three lines for SC-p interactions
4282 c           do k=1,3
4283 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4284 c           enddo
4285 cgrad          else
4286 cd          write (iout,*) 'j>i'
4287 cgrad            do k=1,3
4288 cgrad              ggg(k)=-ggg(k)
4289 C Uncomment following line for SC-p interactions
4290 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4291 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4292 cgrad            enddo
4293 cgrad          endif
4294 cgrad          do k=1,3
4295 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4296 cgrad          enddo
4297 cgrad          kstart=min0(i+1,j)
4298 cgrad          kend=max0(i-1,j-1)
4299 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4300 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4301 cgrad          do k=kstart,kend
4302 cgrad            do l=1,3
4303 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4304 cgrad            enddo
4305 cgrad          enddo
4306           do k=1,3
4307             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4308             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4309           enddo
4310         enddo
4311
4312         enddo ! iint
4313       enddo ! i
4314       do i=1,nct
4315         do j=1,3
4316           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4317           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4318           gradx_scp(j,i)=expon*gradx_scp(j,i)
4319         enddo
4320       enddo
4321 C******************************************************************************
4322 C
4323 C                              N O T E !!!
4324 C
4325 C To save time the factor EXPON has been extracted from ALL components
4326 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4327 C use!
4328 C
4329 C******************************************************************************
4330       return
4331       end
4332 C--------------------------------------------------------------------------
4333       subroutine edis(ehpb)
4334 C
4335 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4336 C
4337       implicit real*8 (a-h,o-z)
4338       include 'DIMENSIONS'
4339       include 'COMMON.SBRIDGE'
4340       include 'COMMON.CHAIN'
4341       include 'COMMON.DERIV'
4342       include 'COMMON.VAR'
4343       include 'COMMON.INTERACT'
4344       include 'COMMON.IOUNITS'
4345       dimension ggg(3)
4346       ehpb=0.0D0
4347 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4348 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4349       if (link_end.eq.0) return
4350       do i=link_start,link_end
4351 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4352 C CA-CA distance used in regularization of structure.
4353         ii=ihpb(i)
4354         jj=jhpb(i)
4355 C iii and jjj point to the residues for which the distance is assigned.
4356         if (ii.gt.nres) then
4357           iii=ii-nres
4358           jjj=jj-nres
4359         else
4360           iii=ii
4361           jjj=jj
4362         endif
4363 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4364 c     &    dhpb(i),dhpb1(i),forcon(i)
4365 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4366 C    distance and angle dependent SS bond potential.
4367 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4368 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4369         if (.not.dyn_ss .and. i.le.nss) then
4370 C 15/02/13 CC dynamic SSbond - additional check
4371          if (ii.gt.nres
4372      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4373           call ssbond_ene(iii,jjj,eij)
4374           ehpb=ehpb+2*eij
4375          endif
4376 cd          write (iout,*) "eij",eij
4377         else if (ii.gt.nres .and. jj.gt.nres) then
4378 c Restraints from contact prediction
4379           dd=dist(ii,jj)
4380           if (dhpb1(i).gt.0.0d0) then
4381             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4382             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4383 c            write (iout,*) "beta nmr",
4384 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4385           else
4386             dd=dist(ii,jj)
4387             rdis=dd-dhpb(i)
4388 C Get the force constant corresponding to this distance.
4389             waga=forcon(i)
4390 C Calculate the contribution to energy.
4391             ehpb=ehpb+waga*rdis*rdis
4392 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4393 C
4394 C Evaluate gradient.
4395 C
4396             fac=waga*rdis/dd
4397           endif
4398           do j=1,3
4399             ggg(j)=fac*(c(j,jj)-c(j,ii))
4400           enddo
4401           do j=1,3
4402             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4403             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4404           enddo
4405           do k=1,3
4406             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4407             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4408           enddo
4409         else
4410 C Calculate the distance between the two points and its difference from the
4411 C target distance.
4412           dd=dist(ii,jj)
4413           if (dhpb1(i).gt.0.0d0) then
4414             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4415             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4416 c            write (iout,*) "alph nmr",
4417 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4418           else
4419             rdis=dd-dhpb(i)
4420 C Get the force constant corresponding to this distance.
4421             waga=forcon(i)
4422 C Calculate the contribution to energy.
4423             ehpb=ehpb+waga*rdis*rdis
4424 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4425 C
4426 C Evaluate gradient.
4427 C
4428             fac=waga*rdis/dd
4429           endif
4430 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4431 cd   &   ' waga=',waga,' fac=',fac
4432             do j=1,3
4433               ggg(j)=fac*(c(j,jj)-c(j,ii))
4434             enddo
4435 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4436 C If this is a SC-SC distance, we need to calculate the contributions to the
4437 C Cartesian gradient in the SC vectors (ghpbx).
4438           if (iii.lt.ii) then
4439           do j=1,3
4440             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4441             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4442           enddo
4443           endif
4444 cgrad        do j=iii,jjj-1
4445 cgrad          do k=1,3
4446 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4447 cgrad          enddo
4448 cgrad        enddo
4449           do k=1,3
4450             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4451             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4452           enddo
4453         endif
4454       enddo
4455       ehpb=0.5D0*ehpb
4456       return
4457       end
4458 C--------------------------------------------------------------------------
4459       subroutine ssbond_ene(i,j,eij)
4460 C
4461 C Calculate the distance and angle dependent SS-bond potential energy
4462 C using a free-energy function derived based on RHF/6-31G** ab initio
4463 C calculations of diethyl disulfide.
4464 C
4465 C A. Liwo and U. Kozlowska, 11/24/03
4466 C
4467       implicit real*8 (a-h,o-z)
4468       include 'DIMENSIONS'
4469       include 'COMMON.SBRIDGE'
4470       include 'COMMON.CHAIN'
4471       include 'COMMON.DERIV'
4472       include 'COMMON.LOCAL'
4473       include 'COMMON.INTERACT'
4474       include 'COMMON.VAR'
4475       include 'COMMON.IOUNITS'
4476       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4477       itypi=itype(i)
4478       xi=c(1,nres+i)
4479       yi=c(2,nres+i)
4480       zi=c(3,nres+i)
4481       dxi=dc_norm(1,nres+i)
4482       dyi=dc_norm(2,nres+i)
4483       dzi=dc_norm(3,nres+i)
4484 c      dsci_inv=dsc_inv(itypi)
4485       dsci_inv=vbld_inv(nres+i)
4486       itypj=itype(j)
4487 c      dscj_inv=dsc_inv(itypj)
4488       dscj_inv=vbld_inv(nres+j)
4489       xj=c(1,nres+j)-xi
4490       yj=c(2,nres+j)-yi
4491       zj=c(3,nres+j)-zi
4492       dxj=dc_norm(1,nres+j)
4493       dyj=dc_norm(2,nres+j)
4494       dzj=dc_norm(3,nres+j)
4495       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4496       rij=dsqrt(rrij)
4497       erij(1)=xj*rij
4498       erij(2)=yj*rij
4499       erij(3)=zj*rij
4500       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4501       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4502       om12=dxi*dxj+dyi*dyj+dzi*dzj
4503       do k=1,3
4504         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4505         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4506       enddo
4507       rij=1.0d0/rij
4508       deltad=rij-d0cm
4509       deltat1=1.0d0-om1
4510       deltat2=1.0d0+om2
4511       deltat12=om2-om1+2.0d0
4512       cosphi=om12-om1*om2
4513       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4514      &  +akct*deltad*deltat12+ebr
4515      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4516 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4517 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4518 c     &  " deltat12",deltat12," eij",eij
4519       ed=2*akcm*deltad+akct*deltat12
4520       pom1=akct*deltad
4521       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4522       eom1=-2*akth*deltat1-pom1-om2*pom2
4523       eom2= 2*akth*deltat2+pom1-om1*pom2
4524       eom12=pom2
4525       do k=1,3
4526         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4527         ghpbx(k,i)=ghpbx(k,i)-ggk
4528      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4529      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4530         ghpbx(k,j)=ghpbx(k,j)+ggk
4531      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4532      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4533         ghpbc(k,i)=ghpbc(k,i)-ggk
4534         ghpbc(k,j)=ghpbc(k,j)+ggk
4535       enddo
4536 C
4537 C Calculate the components of the gradient in DC and X
4538 C
4539 cgrad      do k=i,j-1
4540 cgrad        do l=1,3
4541 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4542 cgrad        enddo
4543 cgrad      enddo
4544       return
4545       end
4546 C--------------------------------------------------------------------------
4547       subroutine ebond(estr)
4548 c
4549 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4550 c
4551       implicit real*8 (a-h,o-z)
4552       include 'DIMENSIONS'
4553       include 'COMMON.LOCAL'
4554       include 'COMMON.GEO'
4555       include 'COMMON.INTERACT'
4556       include 'COMMON.DERIV'
4557       include 'COMMON.VAR'
4558       include 'COMMON.CHAIN'
4559       include 'COMMON.IOUNITS'
4560       include 'COMMON.NAMES'
4561       include 'COMMON.FFIELD'
4562       include 'COMMON.CONTROL'
4563       include 'COMMON.SETUP'
4564       double precision u(3),ud(3)
4565       estr=0.0d0
4566       do i=ibondp_start,ibondp_end
4567         diff = vbld(i)-vbldp0
4568 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4569         estr=estr+diff*diff
4570         do j=1,3
4571           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4572         enddo
4573 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4574       enddo
4575       estr=0.5d0*AKP*estr
4576 c
4577 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4578 c
4579       do i=ibond_start,ibond_end
4580         iti=itype(i)
4581         if (iti.ne.10) then
4582           nbi=nbondterm(iti)
4583           if (nbi.eq.1) then
4584             diff=vbld(i+nres)-vbldsc0(1,iti)
4585 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4586 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4587             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4588             do j=1,3
4589               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4590             enddo
4591           else
4592             do j=1,nbi
4593               diff=vbld(i+nres)-vbldsc0(j,iti)
4594               ud(j)=aksc(j,iti)*diff
4595               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4596             enddo
4597             uprod=u(1)
4598             do j=2,nbi
4599               uprod=uprod*u(j)
4600             enddo
4601             usum=0.0d0
4602             usumsqder=0.0d0
4603             do j=1,nbi
4604               uprod1=1.0d0
4605               uprod2=1.0d0
4606               do k=1,nbi
4607                 if (k.ne.j) then
4608                   uprod1=uprod1*u(k)
4609                   uprod2=uprod2*u(k)*u(k)
4610                 endif
4611               enddo
4612               usum=usum+uprod1
4613               usumsqder=usumsqder+ud(j)*uprod2
4614             enddo
4615             estr=estr+uprod/usum
4616             do j=1,3
4617              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4618             enddo
4619           endif
4620         endif
4621       enddo
4622       return
4623       end
4624 #ifdef CRYST_THETA
4625 C--------------------------------------------------------------------------
4626       subroutine ebend(etheta)
4627 C
4628 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4629 C angles gamma and its derivatives in consecutive thetas and gammas.
4630 C
4631       implicit real*8 (a-h,o-z)
4632       include 'DIMENSIONS'
4633       include 'COMMON.LOCAL'
4634       include 'COMMON.GEO'
4635       include 'COMMON.INTERACT'
4636       include 'COMMON.DERIV'
4637       include 'COMMON.VAR'
4638       include 'COMMON.CHAIN'
4639       include 'COMMON.IOUNITS'
4640       include 'COMMON.NAMES'
4641       include 'COMMON.FFIELD'
4642       include 'COMMON.CONTROL'
4643       common /calcthet/ term1,term2,termm,diffak,ratak,
4644      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4645      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4646       double precision y(2),z(2)
4647       delta=0.02d0*pi
4648 c      time11=dexp(-2*time)
4649 c      time12=1.0d0
4650       etheta=0.0D0
4651 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4652       do i=ithet_start,ithet_end
4653 C Zero the energy function and its derivative at 0 or pi.
4654         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4655         it=itype(i-1)
4656         if (i.gt.3) then
4657 #ifdef OSF
4658           phii=phi(i)
4659           if (phii.ne.phii) phii=150.0
4660 #else
4661           phii=phi(i)
4662 #endif
4663           y(1)=dcos(phii)
4664           y(2)=dsin(phii)
4665         else
4666           y(1)=0.0D0
4667           y(2)=0.0D0
4668         endif
4669         if (i.lt.nres) then
4670 #ifdef OSF
4671           phii1=phi(i+1)
4672           if (phii1.ne.phii1) phii1=150.0
4673           phii1=pinorm(phii1)
4674           z(1)=cos(phii1)
4675 #else
4676           phii1=phi(i+1)
4677           z(1)=dcos(phii1)
4678 #endif
4679           z(2)=dsin(phii1)
4680         else
4681           z(1)=0.0D0
4682           z(2)=0.0D0
4683         endif
4684 C Calculate the "mean" value of theta from the part of the distribution
4685 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4686 C In following comments this theta will be referred to as t_c.
4687         thet_pred_mean=0.0d0
4688         do k=1,2
4689           athetk=athet(k,it)
4690           bthetk=bthet(k,it)
4691           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4692         enddo
4693         dthett=thet_pred_mean*ssd
4694         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4695 C Derivatives of the "mean" values in gamma1 and gamma2.
4696         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4697         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4698         if (theta(i).gt.pi-delta) then
4699           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4700      &         E_tc0)
4701           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4702           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4703           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4704      &        E_theta)
4705           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4706      &        E_tc)
4707         else if (theta(i).lt.delta) then
4708           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4709           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4710           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4711      &        E_theta)
4712           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4713           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4714      &        E_tc)
4715         else
4716           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4717      &        E_theta,E_tc)
4718         endif
4719         etheta=etheta+ethetai
4720         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4721      &      'ebend',i,ethetai
4722         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4723         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4724         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4725       enddo
4726 C Ufff.... We've done all this!!!
4727       return
4728       end
4729 C---------------------------------------------------------------------------
4730       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4731      &     E_tc)
4732       implicit real*8 (a-h,o-z)
4733       include 'DIMENSIONS'
4734       include 'COMMON.LOCAL'
4735       include 'COMMON.IOUNITS'
4736       common /calcthet/ term1,term2,termm,diffak,ratak,
4737      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4738      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4739 C Calculate the contributions to both Gaussian lobes.
4740 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4741 C The "polynomial part" of the "standard deviation" of this part of
4742 C the distribution.
4743         sig=polthet(3,it)
4744         do j=2,0,-1
4745           sig=sig*thet_pred_mean+polthet(j,it)
4746         enddo
4747 C Derivative of the "interior part" of the "standard deviation of the"
4748 C gamma-dependent Gaussian lobe in t_c.
4749         sigtc=3*polthet(3,it)
4750         do j=2,1,-1
4751           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4752         enddo
4753         sigtc=sig*sigtc
4754 C Set the parameters of both Gaussian lobes of the distribution.
4755 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4756         fac=sig*sig+sigc0(it)
4757         sigcsq=fac+fac
4758         sigc=1.0D0/sigcsq
4759 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4760         sigsqtc=-4.0D0*sigcsq*sigtc
4761 c       print *,i,sig,sigtc,sigsqtc
4762 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4763         sigtc=-sigtc/(fac*fac)
4764 C Following variable is sigma(t_c)**(-2)
4765         sigcsq=sigcsq*sigcsq
4766         sig0i=sig0(it)
4767         sig0inv=1.0D0/sig0i**2
4768         delthec=thetai-thet_pred_mean
4769         delthe0=thetai-theta0i
4770         term1=-0.5D0*sigcsq*delthec*delthec
4771         term2=-0.5D0*sig0inv*delthe0*delthe0
4772 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4773 C NaNs in taking the logarithm. We extract the largest exponent which is added
4774 C to the energy (this being the log of the distribution) at the end of energy
4775 C term evaluation for this virtual-bond angle.
4776         if (term1.gt.term2) then
4777           termm=term1
4778           term2=dexp(term2-termm)
4779           term1=1.0d0
4780         else
4781           termm=term2
4782           term1=dexp(term1-termm)
4783           term2=1.0d0
4784         endif
4785 C The ratio between the gamma-independent and gamma-dependent lobes of
4786 C the distribution is a Gaussian function of thet_pred_mean too.
4787         diffak=gthet(2,it)-thet_pred_mean
4788         ratak=diffak/gthet(3,it)**2
4789         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4790 C Let's differentiate it in thet_pred_mean NOW.
4791         aktc=ak*ratak
4792 C Now put together the distribution terms to make complete distribution.
4793         termexp=term1+ak*term2
4794         termpre=sigc+ak*sig0i
4795 C Contribution of the bending energy from this theta is just the -log of
4796 C the sum of the contributions from the two lobes and the pre-exponential
4797 C factor. Simple enough, isn't it?
4798         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4799 C NOW the derivatives!!!
4800 C 6/6/97 Take into account the deformation.
4801         E_theta=(delthec*sigcsq*term1
4802      &       +ak*delthe0*sig0inv*term2)/termexp
4803         E_tc=((sigtc+aktc*sig0i)/termpre
4804      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4805      &       aktc*term2)/termexp)
4806       return
4807       end
4808 c-----------------------------------------------------------------------------
4809       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4810       implicit real*8 (a-h,o-z)
4811       include 'DIMENSIONS'
4812       include 'COMMON.LOCAL'
4813       include 'COMMON.IOUNITS'
4814       common /calcthet/ term1,term2,termm,diffak,ratak,
4815      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4816      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4817       delthec=thetai-thet_pred_mean
4818       delthe0=thetai-theta0i
4819 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4820       t3 = thetai-thet_pred_mean
4821       t6 = t3**2
4822       t9 = term1
4823       t12 = t3*sigcsq
4824       t14 = t12+t6*sigsqtc
4825       t16 = 1.0d0
4826       t21 = thetai-theta0i
4827       t23 = t21**2
4828       t26 = term2
4829       t27 = t21*t26
4830       t32 = termexp
4831       t40 = t32**2
4832       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4833      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4834      & *(-t12*t9-ak*sig0inv*t27)
4835       return
4836       end
4837 #else
4838 C--------------------------------------------------------------------------
4839       subroutine ebend(etheta)
4840 C
4841 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4842 C angles gamma and its derivatives in consecutive thetas and gammas.
4843 C ab initio-derived potentials from
4844 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4845 C
4846       implicit real*8 (a-h,o-z)
4847       include 'DIMENSIONS'
4848       include 'COMMON.LOCAL'
4849       include 'COMMON.GEO'
4850       include 'COMMON.INTERACT'
4851       include 'COMMON.DERIV'
4852       include 'COMMON.VAR'
4853       include 'COMMON.CHAIN'
4854       include 'COMMON.IOUNITS'
4855       include 'COMMON.NAMES'
4856       include 'COMMON.FFIELD'
4857       include 'COMMON.CONTROL'
4858       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4859      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4860      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4861      & sinph1ph2(maxdouble,maxdouble)
4862       logical lprn /.false./, lprn1 /.false./
4863       etheta=0.0D0
4864       do i=ithet_start,ithet_end
4865         dethetai=0.0d0
4866         dephii=0.0d0
4867         dephii1=0.0d0
4868         theti2=0.5d0*theta(i)
4869         ityp2=ithetyp(itype(i-1))
4870         do k=1,nntheterm
4871           coskt(k)=dcos(k*theti2)
4872           sinkt(k)=dsin(k*theti2)
4873         enddo
4874         if (i.gt.3) then
4875 #ifdef OSF
4876           phii=phi(i)
4877           if (phii.ne.phii) phii=150.0
4878 #else
4879           phii=phi(i)
4880 #endif
4881           ityp1=ithetyp(itype(i-2))
4882           do k=1,nsingle
4883             cosph1(k)=dcos(k*phii)
4884             sinph1(k)=dsin(k*phii)
4885           enddo
4886         else
4887           phii=0.0d0
4888           ityp1=nthetyp+1
4889           do k=1,nsingle
4890             cosph1(k)=0.0d0
4891             sinph1(k)=0.0d0
4892           enddo
4893         endif
4894         if (i.lt.nres) then
4895 #ifdef OSF
4896           phii1=phi(i+1)
4897           if (phii1.ne.phii1) phii1=150.0
4898           phii1=pinorm(phii1)
4899 #else
4900           phii1=phi(i+1)
4901 #endif
4902           ityp3=ithetyp(itype(i))
4903           do k=1,nsingle
4904             cosph2(k)=dcos(k*phii1)
4905             sinph2(k)=dsin(k*phii1)
4906           enddo
4907         else
4908           phii1=0.0d0
4909           ityp3=nthetyp+1
4910           do k=1,nsingle
4911             cosph2(k)=0.0d0
4912             sinph2(k)=0.0d0
4913           enddo
4914         endif
4915         ethetai=aa0thet(ityp1,ityp2,ityp3)
4916         do k=1,ndouble
4917           do l=1,k-1
4918             ccl=cosph1(l)*cosph2(k-l)
4919             ssl=sinph1(l)*sinph2(k-l)
4920             scl=sinph1(l)*cosph2(k-l)
4921             csl=cosph1(l)*sinph2(k-l)
4922             cosph1ph2(l,k)=ccl-ssl
4923             cosph1ph2(k,l)=ccl+ssl
4924             sinph1ph2(l,k)=scl+csl
4925             sinph1ph2(k,l)=scl-csl
4926           enddo
4927         enddo
4928         if (lprn) then
4929         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4930      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4931         write (iout,*) "coskt and sinkt"
4932         do k=1,nntheterm
4933           write (iout,*) k,coskt(k),sinkt(k)
4934         enddo
4935         endif
4936         do k=1,ntheterm
4937           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4938           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4939      &      *coskt(k)
4940           if (lprn)
4941      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4942      &     " ethetai",ethetai
4943         enddo
4944         if (lprn) then
4945         write (iout,*) "cosph and sinph"
4946         do k=1,nsingle
4947           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4948         enddo
4949         write (iout,*) "cosph1ph2 and sinph2ph2"
4950         do k=2,ndouble
4951           do l=1,k-1
4952             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4953      &         sinph1ph2(l,k),sinph1ph2(k,l)
4954           enddo
4955         enddo
4956         write(iout,*) "ethetai",ethetai
4957         endif
4958         do m=1,ntheterm2
4959           do k=1,nsingle
4960             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4961      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4962      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4963      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4964             ethetai=ethetai+sinkt(m)*aux
4965             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4966             dephii=dephii+k*sinkt(m)*(
4967      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4968      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4969             dephii1=dephii1+k*sinkt(m)*(
4970      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4971      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4972             if (lprn)
4973      &      write (iout,*) "m",m," k",k," bbthet",
4974      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4975      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4976      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4977      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4978           enddo
4979         enddo
4980         if (lprn)
4981      &  write(iout,*) "ethetai",ethetai
4982         do m=1,ntheterm3
4983           do k=2,ndouble
4984             do l=1,k-1
4985               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4986      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4987      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4988      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4989               ethetai=ethetai+sinkt(m)*aux
4990               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4991               dephii=dephii+l*sinkt(m)*(
4992      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4993      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4994      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4995      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4996               dephii1=dephii1+(k-l)*sinkt(m)*(
4997      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4998      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4999      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
5000      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
5001               if (lprn) then
5002               write (iout,*) "m",m," k",k," l",l," ffthet",
5003      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5004      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5005      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5006      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5007               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5008      &            cosph1ph2(k,l)*sinkt(m),
5009      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5010               endif
5011             enddo
5012           enddo
5013         enddo
5014 10      continue
5015 c        lprn1=.true.
5016         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
5017      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
5018      &   phii1*rad2deg,ethetai
5019 c        lprn1=.false.
5020         etheta=etheta+ethetai
5021         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5022         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5023         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5024       enddo
5025       return
5026       end
5027 #endif
5028 #ifdef CRYST_SC
5029 c-----------------------------------------------------------------------------
5030       subroutine esc(escloc)
5031 C Calculate the local energy of a side chain and its derivatives in the
5032 C corresponding virtual-bond valence angles THETA and the spherical angles
5033 C ALPHA and OMEGA.
5034       implicit real*8 (a-h,o-z)
5035       include 'DIMENSIONS'
5036       include 'COMMON.GEO'
5037       include 'COMMON.LOCAL'
5038       include 'COMMON.VAR'
5039       include 'COMMON.INTERACT'
5040       include 'COMMON.DERIV'
5041       include 'COMMON.CHAIN'
5042       include 'COMMON.IOUNITS'
5043       include 'COMMON.NAMES'
5044       include 'COMMON.FFIELD'
5045       include 'COMMON.CONTROL'
5046       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5047      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5048       common /sccalc/ time11,time12,time112,theti,it,nlobit
5049       delta=0.02d0*pi
5050       escloc=0.0D0
5051 c     write (iout,'(a)') 'ESC'
5052       do i=loc_start,loc_end
5053         it=itype(i)
5054         if (it.eq.10) goto 1
5055         nlobit=nlob(it)
5056 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5057 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5058         theti=theta(i+1)-pipol
5059         x(1)=dtan(theti)
5060         x(2)=alph(i)
5061         x(3)=omeg(i)
5062
5063         if (x(2).gt.pi-delta) then
5064           xtemp(1)=x(1)
5065           xtemp(2)=pi-delta
5066           xtemp(3)=x(3)
5067           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5068           xtemp(2)=pi
5069           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5070           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5071      &        escloci,dersc(2))
5072           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5073      &        ddersc0(1),dersc(1))
5074           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5075      &        ddersc0(3),dersc(3))
5076           xtemp(2)=pi-delta
5077           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5078           xtemp(2)=pi
5079           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5080           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5081      &            dersc0(2),esclocbi,dersc02)
5082           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5083      &            dersc12,dersc01)
5084           call splinthet(x(2),0.5d0*delta,ss,ssd)
5085           dersc0(1)=dersc01
5086           dersc0(2)=dersc02
5087           dersc0(3)=0.0d0
5088           do k=1,3
5089             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5090           enddo
5091           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5092 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5093 c    &             esclocbi,ss,ssd
5094           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5095 c         escloci=esclocbi
5096 c         write (iout,*) escloci
5097         else if (x(2).lt.delta) then
5098           xtemp(1)=x(1)
5099           xtemp(2)=delta
5100           xtemp(3)=x(3)
5101           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5102           xtemp(2)=0.0d0
5103           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5104           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5105      &        escloci,dersc(2))
5106           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5107      &        ddersc0(1),dersc(1))
5108           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5109      &        ddersc0(3),dersc(3))
5110           xtemp(2)=delta
5111           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5112           xtemp(2)=0.0d0
5113           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5114           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5115      &            dersc0(2),esclocbi,dersc02)
5116           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5117      &            dersc12,dersc01)
5118           dersc0(1)=dersc01
5119           dersc0(2)=dersc02
5120           dersc0(3)=0.0d0
5121           call splinthet(x(2),0.5d0*delta,ss,ssd)
5122           do k=1,3
5123             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5124           enddo
5125           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5126 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5127 c    &             esclocbi,ss,ssd
5128           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5129 c         write (iout,*) escloci
5130         else
5131           call enesc(x,escloci,dersc,ddummy,.false.)
5132         endif
5133
5134         escloc=escloc+escloci
5135         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5136      &     'escloc',i,escloci
5137 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5138
5139         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5140      &   wscloc*dersc(1)
5141         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5142         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5143     1   continue
5144       enddo
5145       return
5146       end
5147 C---------------------------------------------------------------------------
5148       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5149       implicit real*8 (a-h,o-z)
5150       include 'DIMENSIONS'
5151       include 'COMMON.GEO'
5152       include 'COMMON.LOCAL'
5153       include 'COMMON.IOUNITS'
5154       common /sccalc/ time11,time12,time112,theti,it,nlobit
5155       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5156       double precision contr(maxlob,-1:1)
5157       logical mixed
5158 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5159         escloc_i=0.0D0
5160         do j=1,3
5161           dersc(j)=0.0D0
5162           if (mixed) ddersc(j)=0.0d0
5163         enddo
5164         x3=x(3)
5165
5166 C Because of periodicity of the dependence of the SC energy in omega we have
5167 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5168 C To avoid underflows, first compute & store the exponents.
5169
5170         do iii=-1,1
5171
5172           x(3)=x3+iii*dwapi
5173
5174           do j=1,nlobit
5175             do k=1,3
5176               z(k)=x(k)-censc(k,j,it)
5177             enddo
5178             do k=1,3
5179               Axk=0.0D0
5180               do l=1,3
5181                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5182               enddo
5183               Ax(k,j,iii)=Axk
5184             enddo
5185             expfac=0.0D0
5186             do k=1,3
5187               expfac=expfac+Ax(k,j,iii)*z(k)
5188             enddo
5189             contr(j,iii)=expfac
5190           enddo ! j
5191
5192         enddo ! iii
5193
5194         x(3)=x3
5195 C As in the case of ebend, we want to avoid underflows in exponentiation and
5196 C subsequent NaNs and INFs in energy calculation.
5197 C Find the largest exponent
5198         emin=contr(1,-1)
5199         do iii=-1,1
5200           do j=1,nlobit
5201             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5202           enddo
5203         enddo
5204         emin=0.5D0*emin
5205 cd      print *,'it=',it,' emin=',emin
5206
5207 C Compute the contribution to SC energy and derivatives
5208         do iii=-1,1
5209
5210           do j=1,nlobit
5211 #ifdef OSF
5212             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5213             if(adexp.ne.adexp) adexp=1.0
5214             expfac=dexp(adexp)
5215 #else
5216             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5217 #endif
5218 cd          print *,'j=',j,' expfac=',expfac
5219             escloc_i=escloc_i+expfac
5220             do k=1,3
5221               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5222             enddo
5223             if (mixed) then
5224               do k=1,3,2
5225                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5226      &            +gaussc(k,2,j,it))*expfac
5227               enddo
5228             endif
5229           enddo
5230
5231         enddo ! iii
5232
5233         dersc(1)=dersc(1)/cos(theti)**2
5234         ddersc(1)=ddersc(1)/cos(theti)**2
5235         ddersc(3)=ddersc(3)
5236
5237         escloci=-(dlog(escloc_i)-emin)
5238         do j=1,3
5239           dersc(j)=dersc(j)/escloc_i
5240         enddo
5241         if (mixed) then
5242           do j=1,3,2
5243             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5244           enddo
5245         endif
5246       return
5247       end
5248 C------------------------------------------------------------------------------
5249       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5250       implicit real*8 (a-h,o-z)
5251       include 'DIMENSIONS'
5252       include 'COMMON.GEO'
5253       include 'COMMON.LOCAL'
5254       include 'COMMON.IOUNITS'
5255       common /sccalc/ time11,time12,time112,theti,it,nlobit
5256       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5257       double precision contr(maxlob)
5258       logical mixed
5259
5260       escloc_i=0.0D0
5261
5262       do j=1,3
5263         dersc(j)=0.0D0
5264       enddo
5265
5266       do j=1,nlobit
5267         do k=1,2
5268           z(k)=x(k)-censc(k,j,it)
5269         enddo
5270         z(3)=dwapi
5271         do k=1,3
5272           Axk=0.0D0
5273           do l=1,3
5274             Axk=Axk+gaussc(l,k,j,it)*z(l)
5275           enddo
5276           Ax(k,j)=Axk
5277         enddo
5278         expfac=0.0D0
5279         do k=1,3
5280           expfac=expfac+Ax(k,j)*z(k)
5281         enddo
5282         contr(j)=expfac
5283       enddo ! j
5284
5285 C As in the case of ebend, we want to avoid underflows in exponentiation and
5286 C subsequent NaNs and INFs in energy calculation.
5287 C Find the largest exponent
5288       emin=contr(1)
5289       do j=1,nlobit
5290         if (emin.gt.contr(j)) emin=contr(j)
5291       enddo
5292       emin=0.5D0*emin
5293
5294 C Compute the contribution to SC energy and derivatives
5295
5296       dersc12=0.0d0
5297       do j=1,nlobit
5298         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5299         escloc_i=escloc_i+expfac
5300         do k=1,2
5301           dersc(k)=dersc(k)+Ax(k,j)*expfac
5302         enddo
5303         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5304      &            +gaussc(1,2,j,it))*expfac
5305         dersc(3)=0.0d0
5306       enddo
5307
5308       dersc(1)=dersc(1)/cos(theti)**2
5309       dersc12=dersc12/cos(theti)**2
5310       escloci=-(dlog(escloc_i)-emin)
5311       do j=1,2
5312         dersc(j)=dersc(j)/escloc_i
5313       enddo
5314       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5315       return
5316       end
5317 #else
5318 c----------------------------------------------------------------------------------
5319       subroutine esc(escloc)
5320 C Calculate the local energy of a side chain and its derivatives in the
5321 C corresponding virtual-bond valence angles THETA and the spherical angles
5322 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5323 C added by Urszula Kozlowska. 07/11/2007
5324 C
5325       implicit real*8 (a-h,o-z)
5326       include 'DIMENSIONS'
5327       include 'COMMON.GEO'
5328       include 'COMMON.LOCAL'
5329       include 'COMMON.VAR'
5330       include 'COMMON.SCROT'
5331       include 'COMMON.INTERACT'
5332       include 'COMMON.DERIV'
5333       include 'COMMON.CHAIN'
5334       include 'COMMON.IOUNITS'
5335       include 'COMMON.NAMES'
5336       include 'COMMON.FFIELD'
5337       include 'COMMON.CONTROL'
5338       include 'COMMON.VECTORS'
5339       double precision x_prime(3),y_prime(3),z_prime(3)
5340      &    , sumene,dsc_i,dp2_i,x(65),
5341      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5342      &    de_dxx,de_dyy,de_dzz,de_dt
5343       double precision s1_t,s1_6_t,s2_t,s2_6_t
5344       double precision
5345      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5346      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5347      & dt_dCi(3),dt_dCi1(3)
5348       common /sccalc/ time11,time12,time112,theti,it,nlobit
5349       delta=0.02d0*pi
5350       escloc=0.0D0
5351       do i=loc_start,loc_end
5352         costtab(i+1) =dcos(theta(i+1))
5353         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5354         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5355         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5356         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5357         cosfac=dsqrt(cosfac2)
5358         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5359         sinfac=dsqrt(sinfac2)
5360         it=itype(i)
5361         if (it.eq.10) goto 1
5362 c
5363 C  Compute the axes of tghe local cartesian coordinates system; store in
5364 c   x_prime, y_prime and z_prime
5365 c
5366         do j=1,3
5367           x_prime(j) = 0.00
5368           y_prime(j) = 0.00
5369           z_prime(j) = 0.00
5370         enddo
5371 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5372 C     &   dc_norm(3,i+nres)
5373         do j = 1,3
5374           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5375           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5376         enddo
5377         do j = 1,3
5378           z_prime(j) = -uz(j,i-1)
5379         enddo
5380 c       write (2,*) "i",i
5381 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5382 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5383 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5384 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5385 c      & " xy",scalar(x_prime(1),y_prime(1)),
5386 c      & " xz",scalar(x_prime(1),z_prime(1)),
5387 c      & " yy",scalar(y_prime(1),y_prime(1)),
5388 c      & " yz",scalar(y_prime(1),z_prime(1)),
5389 c      & " zz",scalar(z_prime(1),z_prime(1))
5390 c
5391 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5392 C to local coordinate system. Store in xx, yy, zz.
5393 c
5394         xx=0.0d0
5395         yy=0.0d0
5396         zz=0.0d0
5397         do j = 1,3
5398           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5399           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5400           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5401         enddo
5402
5403         xxtab(i)=xx
5404         yytab(i)=yy
5405         zztab(i)=zz
5406 C
5407 C Compute the energy of the ith side cbain
5408 C
5409 c        write (2,*) "xx",xx," yy",yy," zz",zz
5410         it=itype(i)
5411         do j = 1,65
5412           x(j) = sc_parmin(j,it)
5413         enddo
5414 #ifdef CHECK_COORD
5415 Cc diagnostics - remove later
5416         xx1 = dcos(alph(2))
5417         yy1 = dsin(alph(2))*dcos(omeg(2))
5418         zz1 = -dsin(alph(2))*dsin(omeg(2))
5419         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5420      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5421      &    xx1,yy1,zz1
5422 C,"  --- ", xx_w,yy_w,zz_w
5423 c end diagnostics
5424 #endif
5425         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5426      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5427      &   + x(10)*yy*zz
5428         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5429      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5430      & + x(20)*yy*zz
5431         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5432      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5433      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5434      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5435      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5436      &  +x(40)*xx*yy*zz
5437         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5438      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5439      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5440      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5441      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5442      &  +x(60)*xx*yy*zz
5443         dsc_i   = 0.743d0+x(61)
5444         dp2_i   = 1.9d0+x(62)
5445         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5446      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5447         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5448      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5449         s1=(1+x(63))/(0.1d0 + dscp1)
5450         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5451         s2=(1+x(65))/(0.1d0 + dscp2)
5452         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5453         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5454      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5455 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5456 c     &   sumene4,
5457 c     &   dscp1,dscp2,sumene
5458 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5459         escloc = escloc + sumene
5460 c        write (2,*) "i",i," escloc",sumene,escloc
5461 #ifdef DEBUG
5462 C
5463 C This section to check the numerical derivatives of the energy of ith side
5464 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5465 C #define DEBUG in the code to turn it on.
5466 C
5467         write (2,*) "sumene               =",sumene
5468         aincr=1.0d-7
5469         xxsave=xx
5470         xx=xx+aincr
5471         write (2,*) xx,yy,zz
5472         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5473         de_dxx_num=(sumenep-sumene)/aincr
5474         xx=xxsave
5475         write (2,*) "xx+ sumene from enesc=",sumenep
5476         yysave=yy
5477         yy=yy+aincr
5478         write (2,*) xx,yy,zz
5479         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5480         de_dyy_num=(sumenep-sumene)/aincr
5481         yy=yysave
5482         write (2,*) "yy+ sumene from enesc=",sumenep
5483         zzsave=zz
5484         zz=zz+aincr
5485         write (2,*) xx,yy,zz
5486         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5487         de_dzz_num=(sumenep-sumene)/aincr
5488         zz=zzsave
5489         write (2,*) "zz+ sumene from enesc=",sumenep
5490         costsave=cost2tab(i+1)
5491         sintsave=sint2tab(i+1)
5492         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5493         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5494         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5495         de_dt_num=(sumenep-sumene)/aincr
5496         write (2,*) " t+ sumene from enesc=",sumenep
5497         cost2tab(i+1)=costsave
5498         sint2tab(i+1)=sintsave
5499 C End of diagnostics section.
5500 #endif
5501 C
5502 C Compute the gradient of esc
5503 C
5504         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5505         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5506         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5507         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5508         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5509         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5510         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5511         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5512         pom1=(sumene3*sint2tab(i+1)+sumene1)
5513      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5514         pom2=(sumene4*cost2tab(i+1)+sumene2)
5515      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5516         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5517         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5518      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5519      &  +x(40)*yy*zz
5520         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5521         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5522      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5523      &  +x(60)*yy*zz
5524         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5525      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5526      &        +(pom1+pom2)*pom_dx
5527 #ifdef DEBUG
5528         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5529 #endif
5530 C
5531         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5532         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5533      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5534      &  +x(40)*xx*zz
5535         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5536         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5537      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5538      &  +x(59)*zz**2 +x(60)*xx*zz
5539         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5540      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5541      &        +(pom1-pom2)*pom_dy
5542 #ifdef DEBUG
5543         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5544 #endif
5545 C
5546         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5547      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5548      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5549      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5550      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5551      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5552      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5553      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5554 #ifdef DEBUG
5555         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5556 #endif
5557 C
5558         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5559      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5560      &  +pom1*pom_dt1+pom2*pom_dt2
5561 #ifdef DEBUG
5562         write(2,*), "de_dt = ", de_dt,de_dt_num
5563 #endif
5564 c
5565 C
5566        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5567        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5568        cosfac2xx=cosfac2*xx
5569        sinfac2yy=sinfac2*yy
5570        do k = 1,3
5571          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5572      &      vbld_inv(i+1)
5573          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5574      &      vbld_inv(i)
5575          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5576          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5577 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5578 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5579 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5580 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5581          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5582          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5583          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5584          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5585          dZZ_Ci1(k)=0.0d0
5586          dZZ_Ci(k)=0.0d0
5587          do j=1,3
5588            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5589            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5590          enddo
5591
5592          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5593          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5594          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5595 c
5596          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5597          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5598        enddo
5599
5600        do k=1,3
5601          dXX_Ctab(k,i)=dXX_Ci(k)
5602          dXX_C1tab(k,i)=dXX_Ci1(k)
5603          dYY_Ctab(k,i)=dYY_Ci(k)
5604          dYY_C1tab(k,i)=dYY_Ci1(k)
5605          dZZ_Ctab(k,i)=dZZ_Ci(k)
5606          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5607          dXX_XYZtab(k,i)=dXX_XYZ(k)
5608          dYY_XYZtab(k,i)=dYY_XYZ(k)
5609          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5610        enddo
5611
5612        do k = 1,3
5613 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5614 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5615 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5616 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5617 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5618 c     &    dt_dci(k)
5619 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5620 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5621          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5622      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5623          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5624      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5625          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5626      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5627        enddo
5628 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5629 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5630
5631 C to check gradient call subroutine check_grad
5632
5633     1 continue
5634       enddo
5635       return
5636       end
5637 c------------------------------------------------------------------------------
5638       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5639       implicit none
5640       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5641      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5642       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5643      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5644      &   + x(10)*yy*zz
5645       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5646      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5647      & + x(20)*yy*zz
5648       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5649      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5650      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5651      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5652      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5653      &  +x(40)*xx*yy*zz
5654       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5655      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5656      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5657      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5658      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5659      &  +x(60)*xx*yy*zz
5660       dsc_i   = 0.743d0+x(61)
5661       dp2_i   = 1.9d0+x(62)
5662       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5663      &          *(xx*cost2+yy*sint2))
5664       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5665      &          *(xx*cost2-yy*sint2))
5666       s1=(1+x(63))/(0.1d0 + dscp1)
5667       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5668       s2=(1+x(65))/(0.1d0 + dscp2)
5669       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5670       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5671      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5672       enesc=sumene
5673       return
5674       end
5675 #endif
5676 c------------------------------------------------------------------------------
5677       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5678 C
5679 C This procedure calculates two-body contact function g(rij) and its derivative:
5680 C
5681 C           eps0ij                                     !       x < -1
5682 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5683 C            0                                         !       x > 1
5684 C
5685 C where x=(rij-r0ij)/delta
5686 C
5687 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5688 C
5689       implicit none
5690       double precision rij,r0ij,eps0ij,fcont,fprimcont
5691       double precision x,x2,x4,delta
5692 c     delta=0.02D0*r0ij
5693 c      delta=0.2D0*r0ij
5694       x=(rij-r0ij)/delta
5695       if (x.lt.-1.0D0) then
5696         fcont=eps0ij
5697         fprimcont=0.0D0
5698       else if (x.le.1.0D0) then
5699         x2=x*x
5700         x4=x2*x2
5701         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5702         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5703       else
5704         fcont=0.0D0
5705         fprimcont=0.0D0
5706       endif
5707       return
5708       end
5709 c------------------------------------------------------------------------------
5710       subroutine splinthet(theti,delta,ss,ssder)
5711       implicit real*8 (a-h,o-z)
5712       include 'DIMENSIONS'
5713       include 'COMMON.VAR'
5714       include 'COMMON.GEO'
5715       thetup=pi-delta
5716       thetlow=delta
5717       if (theti.gt.pipol) then
5718         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5719       else
5720         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5721         ssder=-ssder
5722       endif
5723       return
5724       end
5725 c------------------------------------------------------------------------------
5726       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5727       implicit none
5728       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5729       double precision ksi,ksi2,ksi3,a1,a2,a3
5730       a1=fprim0*delta/(f1-f0)
5731       a2=3.0d0-2.0d0*a1
5732       a3=a1-2.0d0
5733       ksi=(x-x0)/delta
5734       ksi2=ksi*ksi
5735       ksi3=ksi2*ksi
5736       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5737       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5738       return
5739       end
5740 c------------------------------------------------------------------------------
5741       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5742       implicit none
5743       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5744       double precision ksi,ksi2,ksi3,a1,a2,a3
5745       ksi=(x-x0)/delta
5746       ksi2=ksi*ksi
5747       ksi3=ksi2*ksi
5748       a1=fprim0x*delta
5749       a2=3*(f1x-f0x)-2*fprim0x*delta
5750       a3=fprim0x*delta-2*(f1x-f0x)
5751       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5752       return
5753       end
5754 C-----------------------------------------------------------------------------
5755 #ifdef CRYST_TOR
5756 C-----------------------------------------------------------------------------
5757       subroutine etor(etors,edihcnstr)
5758       implicit real*8 (a-h,o-z)
5759       include 'DIMENSIONS'
5760       include 'COMMON.VAR'
5761       include 'COMMON.GEO'
5762       include 'COMMON.LOCAL'
5763       include 'COMMON.TORSION'
5764       include 'COMMON.INTERACT'
5765       include 'COMMON.DERIV'
5766       include 'COMMON.CHAIN'
5767       include 'COMMON.NAMES'
5768       include 'COMMON.IOUNITS'
5769       include 'COMMON.FFIELD'
5770       include 'COMMON.TORCNSTR'
5771       include 'COMMON.CONTROL'
5772       logical lprn
5773 C Set lprn=.true. for debugging
5774       lprn=.false.
5775 c      lprn=.true.
5776       etors=0.0D0
5777       do i=iphi_start,iphi_end
5778       etors_ii=0.0D0
5779         itori=itortyp(itype(i-2))
5780         itori1=itortyp(itype(i-1))
5781         phii=phi(i)
5782         gloci=0.0D0
5783 C Proline-Proline pair is a special case...
5784         if (itori.eq.3 .and. itori1.eq.3) then
5785           if (phii.gt.-dwapi3) then
5786             cosphi=dcos(3*phii)
5787             fac=1.0D0/(1.0D0-cosphi)
5788             etorsi=v1(1,3,3)*fac
5789             etorsi=etorsi+etorsi
5790             etors=etors+etorsi-v1(1,3,3)
5791             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5792             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5793           endif
5794           do j=1,3
5795             v1ij=v1(j+1,itori,itori1)
5796             v2ij=v2(j+1,itori,itori1)
5797             cosphi=dcos(j*phii)
5798             sinphi=dsin(j*phii)
5799             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5800             if (energy_dec) etors_ii=etors_ii+
5801      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5802             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5803           enddo
5804         else
5805           do j=1,nterm_old
5806             v1ij=v1(j,itori,itori1)
5807             v2ij=v2(j,itori,itori1)
5808             cosphi=dcos(j*phii)
5809             sinphi=dsin(j*phii)
5810             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5811             if (energy_dec) etors_ii=etors_ii+
5812      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5813             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5814           enddo
5815         endif
5816         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5817      &        'etor',i,etors_ii
5818         if (lprn)
5819      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5820      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5821      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5822         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5823         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5824       enddo
5825 ! 6/20/98 - dihedral angle constraints
5826       edihcnstr=0.0d0
5827       do i=1,ndih_constr
5828         itori=idih_constr(i)
5829         phii=phi(itori)
5830         difi=phii-phi0(i)
5831         if (difi.gt.drange(i)) then
5832           difi=difi-drange(i)
5833           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5834           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5835         else if (difi.lt.-drange(i)) then
5836           difi=difi+drange(i)
5837           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5838           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5839         endif
5840 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5841 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5842       enddo
5843 !      write (iout,*) 'edihcnstr',edihcnstr
5844       return
5845       end
5846 c------------------------------------------------------------------------------
5847 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5848       subroutine e_modeller(ehomology_constr)
5849       ehomology_constr=0.0
5850       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5851       return
5852       end
5853 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5854
5855 c------------------------------------------------------------------------------
5856       subroutine etor_d(etors_d)
5857       etors_d=0.0d0
5858       return
5859       end
5860 c----------------------------------------------------------------------------
5861 #else
5862       subroutine etor(etors,edihcnstr)
5863       implicit real*8 (a-h,o-z)
5864       include 'DIMENSIONS'
5865       include 'COMMON.VAR'
5866       include 'COMMON.GEO'
5867       include 'COMMON.LOCAL'
5868       include 'COMMON.TORSION'
5869       include 'COMMON.INTERACT'
5870       include 'COMMON.DERIV'
5871       include 'COMMON.CHAIN'
5872       include 'COMMON.NAMES'
5873       include 'COMMON.IOUNITS'
5874       include 'COMMON.FFIELD'
5875       include 'COMMON.TORCNSTR'
5876       include 'COMMON.CONTROL'
5877       logical lprn
5878 C Set lprn=.true. for debugging
5879       lprn=.false.
5880 c     lprn=.true.
5881       etors=0.0D0
5882       do i=iphi_start,iphi_end
5883       etors_ii=0.0D0
5884         itori=itortyp(itype(i-2))
5885         itori1=itortyp(itype(i-1))
5886         phii=phi(i)
5887         gloci=0.0D0
5888 C Regular cosine and sine terms
5889         do j=1,nterm(itori,itori1)
5890           v1ij=v1(j,itori,itori1)
5891           v2ij=v2(j,itori,itori1)
5892           cosphi=dcos(j*phii)
5893           sinphi=dsin(j*phii)
5894           etors=etors+v1ij*cosphi+v2ij*sinphi
5895           if (energy_dec) etors_ii=etors_ii+
5896      &                v1ij*cosphi+v2ij*sinphi
5897           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5898         enddo
5899 C Lorentz terms
5900 C                         v1
5901 C  E = SUM ----------------------------------- - v1
5902 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5903 C
5904         cosphi=dcos(0.5d0*phii)
5905         sinphi=dsin(0.5d0*phii)
5906         do j=1,nlor(itori,itori1)
5907           vl1ij=vlor1(j,itori,itori1)
5908           vl2ij=vlor2(j,itori,itori1)
5909           vl3ij=vlor3(j,itori,itori1)
5910           pom=vl2ij*cosphi+vl3ij*sinphi
5911           pom1=1.0d0/(pom*pom+1.0d0)
5912           etors=etors+vl1ij*pom1
5913           if (energy_dec) etors_ii=etors_ii+
5914      &                vl1ij*pom1
5915           pom=-pom*pom1*pom1
5916           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5917         enddo
5918 C Subtract the constant term
5919         etors=etors-v0(itori,itori1)
5920           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5921      &         'etor',i,etors_ii-v0(itori,itori1)
5922         if (lprn)
5923      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5924      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5925      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5926         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5927 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5928       enddo
5929 ! 6/20/98 - dihedral angle constraints
5930       edihcnstr=0.0d0
5931 c      do i=1,ndih_constr
5932       do i=idihconstr_start,idihconstr_end
5933         itori=idih_constr(i)
5934         phii=phi(itori)
5935         difi=pinorm(phii-phi0(i))
5936         if (difi.gt.drange(i)) then
5937           difi=difi-drange(i)
5938           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5939           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5940         else if (difi.lt.-drange(i)) then
5941           difi=difi+drange(i)
5942           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5943           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5944         else
5945           difi=0.0
5946         endif
5947 c        write (iout,*) "gloci", gloc(i-3,icg)
5948 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5949 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5950 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5951       enddo
5952 cd       write (iout,*) 'edihcnstr',edihcnstr
5953       return
5954       end
5955 c----------------------------------------------------------------------------
5956 c MODELLER restraint function
5957       subroutine e_modeller(ehomology_constr)
5958       implicit real*8 (a-h,o-z)
5959       include 'DIMENSIONS'
5960
5961       integer nnn, i, j, k, ki, irec, l
5962       integer katy, odleglosci, test7
5963       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
5964       real*8 distance(max_template),distancek(max_template),
5965      &    min_odl,godl(max_template),dih_diff(max_template)
5966
5967       include 'COMMON.SBRIDGE'
5968       include 'COMMON.CHAIN'
5969       include 'COMMON.GEO'
5970       include 'COMMON.DERIV'
5971       include 'COMMON.LOCAL'
5972       include 'COMMON.INTERACT'
5973       include 'COMMON.VAR'
5974       include 'COMMON.IOUNITS'
5975       include 'COMMON.MD'
5976       include 'COMMON.CONTROL'
5977
5978
5979       do i=1,19
5980         distancek(i)=9999999.9
5981       enddo
5982
5983
5984       odleg=0.0d0
5985
5986 c Pseudo-energy and gradient from homology restraints (MODELLER-like
5987 c function)
5988 C AL 5/2/14 - Introduce list of restraints
5989       do ii = link_start_homo,link_end_homo
5990          i = ires_homo(ii)
5991          j = jres_homo(ii)
5992          dij=dist(i,j)
5993          do k=1,constr_homology
5994            distance(k)=odl(k,ii)-dij
5995            distancek(k)=
5996      &        0.5d0*waga_dist(iset)*distance(k)**2*sigma_odl(k,ii)
5997          enddo
5998
5999          min_odl=minval(distancek)
6000 #ifdef DEBUG
6001          write (iout,*) "ij dij",i,j,dij
6002          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6003          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6004          write (iout,* )"min_odl",min_odl
6005 #endif
6006          odleg2=0.0d0
6007          do k=1,constr_homology
6008 c Nie wiem po co to liczycie jeszcze raz!
6009 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
6010 c     &              (2*(sigma_odl(i,j,k))**2))
6011             godl(k)=dexp(-distancek(k)+min_odl)
6012             odleg2=odleg2+godl(k)
6013
6014 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6015 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6016 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6017 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6018
6019          enddo
6020 #ifdef DEBUG
6021          write (iout,*) "godl",(godl(k),k=1,constr_homology)
6022          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2
6023 #endif
6024          odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6025 c Gradient
6026          sum_godl=odleg2
6027          sum_sgodl=0.0
6028          do k=1,constr_homology
6029 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6030 c     &           *waga_dist(iset))+min_odl
6031            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist(iset)
6032            sum_sgodl=sum_sgodl+sgodl
6033
6034 c            sgodl2=sgodl2+sgodl
6035 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6036 c      write(iout,*) "constr_homology=",constr_homology
6037 c      write(iout,*) i, j, k, "TEST K"
6038          enddo
6039
6040          grad_odl3=sum_sgodl/(sum_godl*dij)
6041
6042
6043 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6044 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6045 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6046
6047 ccc      write(iout,*) godl, sgodl, grad_odl3
6048
6049 c          grad_odl=grad_odl+grad_odl3
6050
6051          do jik=1,3
6052             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
6053 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6054 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6055 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6056             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
6057             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
6058 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6059 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6060
6061          enddo
6062 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
6063 ccc     & dLOG(odleg2),"-odleg=", -odleg
6064
6065       enddo ! ii
6066 c Pseudo-energy and gradient from dihedral-angle restraints from
6067 c homology templates
6068 c      write (iout,*) "End of distance loop"
6069 c      call flush(iout)
6070       kat=0.0d0
6071 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6072       do i=idihconstr_start_homo,idihconstr_end_homo
6073         kat2=0.0d0
6074 c        betai=beta(i,i+1,i+2,i+3)
6075         betai = phi(i+3)
6076         do k=1,constr_homology
6077           dih_diff(k)=pinorm(dih(k,i)-betai)
6078 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6079 c     &                                   -(6.28318-dih_diff(i,k))
6080 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6081 c     &                                   6.28318+dih_diff(i,k)
6082
6083           kat3=-0.5d0*waga_angle(iset)*dih_diff(k)**2*sigma_dih(k,i)
6084           gdih(k)=dexp(kat3)
6085           kat2=kat2+gdih(k)
6086 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
6087 c          write(*,*)""
6088         enddo
6089 #ifdef DEBUG
6090         write (iout,*) "i",i," betai",betai," kat2",kat2
6091         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6092 #endif
6093         if (kat2.le.1.0d-14) cycle
6094         kat=kat-dLOG(kat2/constr_homology)
6095
6096 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6097 ccc     & dLOG(kat2), "-kat=", -kat
6098
6099 c ----------------------------------------------------------------------
6100 c Gradient
6101 c ----------------------------------------------------------------------
6102
6103         sum_gdih=kat2
6104         sum_sgdih=0.0
6105         do k=1,constr_homology
6106           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle(iset)
6107           sum_sgdih=sum_sgdih+sgdih
6108         enddo
6109         grad_dih3=sum_sgdih/sum_gdih
6110
6111 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6112 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6113 ccc     & gloc(nphi+i-3,icg)
6114         gloc(i,icg)=gloc(i,icg)+grad_dih3
6115 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6116 ccc     & gloc(nphi+i-3,icg)
6117
6118       enddo
6119
6120
6121 c Total energy from homology restraints
6122 #ifdef DEBUG
6123       write (iout,*) "odleg",odleg," kat",kat
6124 #endif
6125       ehomology_constr=odleg+kat
6126       return
6127
6128   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6129   747 format(a12,i4,i4,i4,f8.3,f8.3)
6130   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6131   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6132   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6133      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6134       end
6135
6136 c------------------------------------------------------------------------------
6137       subroutine etor_d(etors_d)
6138 C 6/23/01 Compute double torsional energy
6139       implicit real*8 (a-h,o-z)
6140       include 'DIMENSIONS'
6141       include 'COMMON.VAR'
6142       include 'COMMON.GEO'
6143       include 'COMMON.LOCAL'
6144       include 'COMMON.TORSION'
6145       include 'COMMON.INTERACT'
6146       include 'COMMON.DERIV'
6147       include 'COMMON.CHAIN'
6148       include 'COMMON.NAMES'
6149       include 'COMMON.IOUNITS'
6150       include 'COMMON.FFIELD'
6151       include 'COMMON.TORCNSTR'
6152       logical lprn
6153 C Set lprn=.true. for debugging
6154       lprn=.false.
6155 c     lprn=.true.
6156       etors_d=0.0D0
6157       do i=iphid_start,iphid_end
6158         itori=itortyp(itype(i-2))
6159         itori1=itortyp(itype(i-1))
6160         itori2=itortyp(itype(i))
6161         phii=phi(i)
6162         phii1=phi(i+1)
6163         gloci1=0.0D0
6164         gloci2=0.0D0
6165         do j=1,ntermd_1(itori,itori1,itori2)
6166           v1cij=v1c(1,j,itori,itori1,itori2)
6167           v1sij=v1s(1,j,itori,itori1,itori2)
6168           v2cij=v1c(2,j,itori,itori1,itori2)
6169           v2sij=v1s(2,j,itori,itori1,itori2)
6170           cosphi1=dcos(j*phii)
6171           sinphi1=dsin(j*phii)
6172           cosphi2=dcos(j*phii1)
6173           sinphi2=dsin(j*phii1)
6174           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6175      &     v2cij*cosphi2+v2sij*sinphi2
6176           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6177           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6178         enddo
6179         do k=2,ntermd_2(itori,itori1,itori2)
6180           do l=1,k-1
6181             v1cdij = v2c(k,l,itori,itori1,itori2)
6182             v2cdij = v2c(l,k,itori,itori1,itori2)
6183             v1sdij = v2s(k,l,itori,itori1,itori2)
6184             v2sdij = v2s(l,k,itori,itori1,itori2)
6185             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6186             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6187             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6188             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6189             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6190      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6191             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6192      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6193             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6194      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6195           enddo
6196         enddo
6197         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6198         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6199 c        write (iout,*) "gloci", gloc(i-3,icg)
6200       enddo
6201       return
6202       end
6203 #endif
6204 c------------------------------------------------------------------------------
6205       subroutine eback_sc_corr(esccor)
6206 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6207 c        conformational states; temporarily implemented as differences
6208 c        between UNRES torsional potentials (dependent on three types of
6209 c        residues) and the torsional potentials dependent on all 20 types
6210 c        of residues computed from AM1  energy surfaces of terminally-blocked
6211 c        amino-acid residues.
6212       implicit real*8 (a-h,o-z)
6213       include 'DIMENSIONS'
6214       include 'COMMON.VAR'
6215       include 'COMMON.GEO'
6216       include 'COMMON.LOCAL'
6217       include 'COMMON.TORSION'
6218       include 'COMMON.SCCOR'
6219       include 'COMMON.INTERACT'
6220       include 'COMMON.DERIV'
6221       include 'COMMON.CHAIN'
6222       include 'COMMON.NAMES'
6223       include 'COMMON.IOUNITS'
6224       include 'COMMON.FFIELD'
6225       include 'COMMON.CONTROL'
6226       logical lprn
6227 C Set lprn=.true. for debugging
6228       lprn=.false.
6229 c      lprn=.true.
6230 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6231       esccor=0.0D0
6232       do i=itau_start,itau_end
6233         esccor_ii=0.0D0
6234         isccori=isccortyp(itype(i-2))
6235         isccori1=isccortyp(itype(i-1))
6236         phii=phi(i)
6237 cccc  Added 9 May 2012
6238 cc Tauangle is torsional engle depending on the value of first digit
6239 c(see comment below)
6240 cc Omicron is flat angle depending on the value of first digit
6241 c(see comment below)
6242
6243
6244         do intertyp=1,3 !intertyp
6245 cc Added 09 May 2012 (Adasko)
6246 cc  Intertyp means interaction type of backbone mainchain correlation:
6247 c   1 = SC...Ca...Ca...Ca
6248 c   2 = Ca...Ca...Ca...SC
6249 c   3 = SC...Ca...Ca...SCi
6250         gloci=0.0D0
6251         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6252      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6253      &      (itype(i-1).eq.21)))
6254      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6255      &     .or.(itype(i-2).eq.21)))
6256      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6257      &      (itype(i-1).eq.21)))) cycle
6258         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6259         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6260      & cycle
6261         do j=1,nterm_sccor(isccori,isccori1)
6262           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6263           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6264           cosphi=dcos(j*tauangle(intertyp,i))
6265           sinphi=dsin(j*tauangle(intertyp,i))
6266           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6267           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6268         enddo
6269         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6270 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6271 c     &gloc_sc(intertyp,i-3,icg)
6272         if (lprn)
6273      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6274      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6275      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6276      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6277         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6278        enddo !intertyp
6279       enddo
6280 c        do i=1,nres
6281 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6282 c        enddo
6283       return
6284       end
6285 c----------------------------------------------------------------------------
6286       subroutine multibody(ecorr)
6287 C This subroutine calculates multi-body contributions to energy following
6288 C the idea of Skolnick et al. If side chains I and J make a contact and
6289 C at the same time side chains I+1 and J+1 make a contact, an extra
6290 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6291       implicit real*8 (a-h,o-z)
6292       include 'DIMENSIONS'
6293       include 'COMMON.IOUNITS'
6294       include 'COMMON.DERIV'
6295       include 'COMMON.INTERACT'
6296       include 'COMMON.CONTACTS'
6297       double precision gx(3),gx1(3)
6298       logical lprn
6299
6300 C Set lprn=.true. for debugging
6301       lprn=.false.
6302
6303       if (lprn) then
6304         write (iout,'(a)') 'Contact function values:'
6305         do i=nnt,nct-2
6306           write (iout,'(i2,20(1x,i2,f10.5))')
6307      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6308         enddo
6309       endif
6310       ecorr=0.0D0
6311       do i=nnt,nct
6312         do j=1,3
6313           gradcorr(j,i)=0.0D0
6314           gradxorr(j,i)=0.0D0
6315         enddo
6316       enddo
6317       do i=nnt,nct-2
6318
6319         DO ISHIFT = 3,4
6320
6321         i1=i+ishift
6322         num_conti=num_cont(i)
6323         num_conti1=num_cont(i1)
6324         do jj=1,num_conti
6325           j=jcont(jj,i)
6326           do kk=1,num_conti1
6327             j1=jcont(kk,i1)
6328             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6329 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6330 cd   &                   ' ishift=',ishift
6331 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6332 C The system gains extra energy.
6333               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6334             endif   ! j1==j+-ishift
6335           enddo     ! kk
6336         enddo       ! jj
6337
6338         ENDDO ! ISHIFT
6339
6340       enddo         ! i
6341       return
6342       end
6343 c------------------------------------------------------------------------------
6344       double precision function esccorr(i,j,k,l,jj,kk)
6345       implicit real*8 (a-h,o-z)
6346       include 'DIMENSIONS'
6347       include 'COMMON.IOUNITS'
6348       include 'COMMON.DERIV'
6349       include 'COMMON.INTERACT'
6350       include 'COMMON.CONTACTS'
6351       double precision gx(3),gx1(3)
6352       logical lprn
6353       lprn=.false.
6354       eij=facont(jj,i)
6355       ekl=facont(kk,k)
6356 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6357 C Calculate the multi-body contribution to energy.
6358 C Calculate multi-body contributions to the gradient.
6359 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6360 cd   & k,l,(gacont(m,kk,k),m=1,3)
6361       do m=1,3
6362         gx(m) =ekl*gacont(m,jj,i)
6363         gx1(m)=eij*gacont(m,kk,k)
6364         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6365         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6366         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6367         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6368       enddo
6369       do m=i,j-1
6370         do ll=1,3
6371           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6372         enddo
6373       enddo
6374       do m=k,l-1
6375         do ll=1,3
6376           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6377         enddo
6378       enddo
6379       esccorr=-eij*ekl
6380       return
6381       end
6382 c------------------------------------------------------------------------------
6383       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6384 C This subroutine calculates multi-body contributions to hydrogen-bonding
6385       implicit real*8 (a-h,o-z)
6386       include 'DIMENSIONS'
6387       include 'COMMON.IOUNITS'
6388 #ifdef MPI
6389       include "mpif.h"
6390       parameter (max_cont=maxconts)
6391       parameter (max_dim=26)
6392       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6393       double precision zapas(max_dim,maxconts,max_fg_procs),
6394      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6395       common /przechowalnia/ zapas
6396       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6397      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6398 #endif
6399       include 'COMMON.SETUP'
6400       include 'COMMON.FFIELD'
6401       include 'COMMON.DERIV'
6402       include 'COMMON.INTERACT'
6403       include 'COMMON.CONTACTS'
6404       include 'COMMON.CONTROL'
6405       include 'COMMON.LOCAL'
6406       double precision gx(3),gx1(3),time00
6407       logical lprn,ldone
6408
6409 C Set lprn=.true. for debugging
6410       lprn=.false.
6411 #ifdef MPI
6412       n_corr=0
6413       n_corr1=0
6414       if (nfgtasks.le.1) goto 30
6415       if (lprn) then
6416         write (iout,'(a)') 'Contact function values before RECEIVE:'
6417         do i=nnt,nct-2
6418           write (iout,'(2i3,50(1x,i2,f5.2))')
6419      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6420      &    j=1,num_cont_hb(i))
6421         enddo
6422       endif
6423       call flush(iout)
6424       do i=1,ntask_cont_from
6425         ncont_recv(i)=0
6426       enddo
6427       do i=1,ntask_cont_to
6428         ncont_sent(i)=0
6429       enddo
6430 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6431 c     & ntask_cont_to
6432 C Make the list of contacts to send to send to other procesors
6433 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6434 c      call flush(iout)
6435       do i=iturn3_start,iturn3_end
6436 c        write (iout,*) "make contact list turn3",i," num_cont",
6437 c     &    num_cont_hb(i)
6438         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6439       enddo
6440       do i=iturn4_start,iturn4_end
6441 c        write (iout,*) "make contact list turn4",i," num_cont",
6442 c     &   num_cont_hb(i)
6443         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6444       enddo
6445       do ii=1,nat_sent
6446         i=iat_sent(ii)
6447 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6448 c     &    num_cont_hb(i)
6449         do j=1,num_cont_hb(i)
6450         do k=1,4
6451           jjc=jcont_hb(j,i)
6452           iproc=iint_sent_local(k,jjc,ii)
6453 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6454           if (iproc.gt.0) then
6455             ncont_sent(iproc)=ncont_sent(iproc)+1
6456             nn=ncont_sent(iproc)
6457             zapas(1,nn,iproc)=i
6458             zapas(2,nn,iproc)=jjc
6459             zapas(3,nn,iproc)=facont_hb(j,i)
6460             zapas(4,nn,iproc)=ees0p(j,i)
6461             zapas(5,nn,iproc)=ees0m(j,i)
6462             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6463             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6464             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6465             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6466             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6467             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6468             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6469             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6470             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6471             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6472             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6473             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6474             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6475             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6476             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6477             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6478             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6479             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6480             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6481             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6482             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6483           endif
6484         enddo
6485         enddo
6486       enddo
6487       if (lprn) then
6488       write (iout,*)
6489      &  "Numbers of contacts to be sent to other processors",
6490      &  (ncont_sent(i),i=1,ntask_cont_to)
6491       write (iout,*) "Contacts sent"
6492       do ii=1,ntask_cont_to
6493         nn=ncont_sent(ii)
6494         iproc=itask_cont_to(ii)
6495         write (iout,*) nn," contacts to processor",iproc,
6496      &   " of CONT_TO_COMM group"
6497         do i=1,nn
6498           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6499         enddo
6500       enddo
6501       call flush(iout)
6502       endif
6503       CorrelType=477
6504       CorrelID=fg_rank+1
6505       CorrelType1=478
6506       CorrelID1=nfgtasks+fg_rank+1
6507       ireq=0
6508 C Receive the numbers of needed contacts from other processors
6509       do ii=1,ntask_cont_from
6510         iproc=itask_cont_from(ii)
6511         ireq=ireq+1
6512         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6513      &    FG_COMM,req(ireq),IERR)
6514       enddo
6515 c      write (iout,*) "IRECV ended"
6516 c      call flush(iout)
6517 C Send the number of contacts needed by other processors
6518       do ii=1,ntask_cont_to
6519         iproc=itask_cont_to(ii)
6520         ireq=ireq+1
6521         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6522      &    FG_COMM,req(ireq),IERR)
6523       enddo
6524 c      write (iout,*) "ISEND ended"
6525 c      write (iout,*) "number of requests (nn)",ireq
6526       call flush(iout)
6527       if (ireq.gt.0)
6528      &  call MPI_Waitall(ireq,req,status_array,ierr)
6529 c      write (iout,*)
6530 c     &  "Numbers of contacts to be received from other processors",
6531 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6532 c      call flush(iout)
6533 C Receive contacts
6534       ireq=0
6535       do ii=1,ntask_cont_from
6536         iproc=itask_cont_from(ii)
6537         nn=ncont_recv(ii)
6538 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6539 c     &   " of CONT_TO_COMM group"
6540         call flush(iout)
6541         if (nn.gt.0) then
6542           ireq=ireq+1
6543           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6544      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6545 c          write (iout,*) "ireq,req",ireq,req(ireq)
6546         endif
6547       enddo
6548 C Send the contacts to processors that need them
6549       do ii=1,ntask_cont_to
6550         iproc=itask_cont_to(ii)
6551         nn=ncont_sent(ii)
6552 c        write (iout,*) nn," contacts to processor",iproc,
6553 c     &   " of CONT_TO_COMM group"
6554         if (nn.gt.0) then
6555           ireq=ireq+1
6556           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6557      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6558 c          write (iout,*) "ireq,req",ireq,req(ireq)
6559 c          do i=1,nn
6560 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6561 c          enddo
6562         endif
6563       enddo
6564 c      write (iout,*) "number of requests (contacts)",ireq
6565 c      write (iout,*) "req",(req(i),i=1,4)
6566 c      call flush(iout)
6567       if (ireq.gt.0)
6568      & call MPI_Waitall(ireq,req,status_array,ierr)
6569       do iii=1,ntask_cont_from
6570         iproc=itask_cont_from(iii)
6571         nn=ncont_recv(iii)
6572         if (lprn) then
6573         write (iout,*) "Received",nn," contacts from processor",iproc,
6574      &   " of CONT_FROM_COMM group"
6575         call flush(iout)
6576         do i=1,nn
6577           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6578         enddo
6579         call flush(iout)
6580         endif
6581         do i=1,nn
6582           ii=zapas_recv(1,i,iii)
6583 c Flag the received contacts to prevent double-counting
6584           jj=-zapas_recv(2,i,iii)
6585 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6586 c          call flush(iout)
6587           nnn=num_cont_hb(ii)+1
6588           num_cont_hb(ii)=nnn
6589           jcont_hb(nnn,ii)=jj
6590           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6591           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6592           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6593           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6594           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6595           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6596           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6597           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6598           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6599           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6600           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6601           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6602           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6603           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6604           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6605           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6606           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6607           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6608           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6609           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6610           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6611           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6612           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6613           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6614         enddo
6615       enddo
6616       call flush(iout)
6617       if (lprn) then
6618         write (iout,'(a)') 'Contact function values after receive:'
6619         do i=nnt,nct-2
6620           write (iout,'(2i3,50(1x,i3,f5.2))')
6621      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6622      &    j=1,num_cont_hb(i))
6623         enddo
6624         call flush(iout)
6625       endif
6626    30 continue
6627 #endif
6628       if (lprn) then
6629         write (iout,'(a)') 'Contact function values:'
6630         do i=nnt,nct-2
6631           write (iout,'(2i3,50(1x,i3,f5.2))')
6632      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6633      &    j=1,num_cont_hb(i))
6634         enddo
6635       endif
6636       ecorr=0.0D0
6637 C Remove the loop below after debugging !!!
6638       do i=nnt,nct
6639         do j=1,3
6640           gradcorr(j,i)=0.0D0
6641           gradxorr(j,i)=0.0D0
6642         enddo
6643       enddo
6644 C Calculate the local-electrostatic correlation terms
6645       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6646         i1=i+1
6647         num_conti=num_cont_hb(i)
6648         num_conti1=num_cont_hb(i+1)
6649         do jj=1,num_conti
6650           j=jcont_hb(jj,i)
6651           jp=iabs(j)
6652           do kk=1,num_conti1
6653             j1=jcont_hb(kk,i1)
6654             jp1=iabs(j1)
6655 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6656 c     &         ' jj=',jj,' kk=',kk
6657             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6658      &          .or. j.lt.0 .and. j1.gt.0) .and.
6659      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6660 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6661 C The system gains extra energy.
6662               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6663               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6664      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6665               n_corr=n_corr+1
6666             else if (j1.eq.j) then
6667 C Contacts I-J and I-(J+1) occur simultaneously.
6668 C The system loses extra energy.
6669 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6670             endif
6671           enddo ! kk
6672           do kk=1,num_conti
6673             j1=jcont_hb(kk,i)
6674 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6675 c    &         ' jj=',jj,' kk=',kk
6676             if (j1.eq.j+1) then
6677 C Contacts I-J and (I+1)-J occur simultaneously.
6678 C The system loses extra energy.
6679 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6680             endif ! j1==j+1
6681           enddo ! kk
6682         enddo ! jj
6683       enddo ! i
6684       return
6685       end
6686 c------------------------------------------------------------------------------
6687       subroutine add_hb_contact(ii,jj,itask)
6688       implicit real*8 (a-h,o-z)
6689       include "DIMENSIONS"
6690       include "COMMON.IOUNITS"
6691       integer max_cont
6692       integer max_dim
6693       parameter (max_cont=maxconts)
6694       parameter (max_dim=26)
6695       include "COMMON.CONTACTS"
6696       double precision zapas(max_dim,maxconts,max_fg_procs),
6697      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6698       common /przechowalnia/ zapas
6699       integer i,j,ii,jj,iproc,itask(4),nn
6700 c      write (iout,*) "itask",itask
6701       do i=1,2
6702         iproc=itask(i)
6703         if (iproc.gt.0) then
6704           do j=1,num_cont_hb(ii)
6705             jjc=jcont_hb(j,ii)
6706 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6707             if (jjc.eq.jj) then
6708               ncont_sent(iproc)=ncont_sent(iproc)+1
6709               nn=ncont_sent(iproc)
6710               zapas(1,nn,iproc)=ii
6711               zapas(2,nn,iproc)=jjc
6712               zapas(3,nn,iproc)=facont_hb(j,ii)
6713               zapas(4,nn,iproc)=ees0p(j,ii)
6714               zapas(5,nn,iproc)=ees0m(j,ii)
6715               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6716               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6717               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6718               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6719               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6720               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6721               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6722               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6723               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6724               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6725               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6726               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6727               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6728               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6729               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6730               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6731               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6732               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6733               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6734               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6735               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6736               exit
6737             endif
6738           enddo
6739         endif
6740       enddo
6741       return
6742       end
6743 c------------------------------------------------------------------------------
6744       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6745      &  n_corr1)
6746 C This subroutine calculates multi-body contributions to hydrogen-bonding
6747       implicit real*8 (a-h,o-z)
6748       include 'DIMENSIONS'
6749       include 'COMMON.IOUNITS'
6750 #ifdef MPI
6751       include "mpif.h"
6752       parameter (max_cont=maxconts)
6753       parameter (max_dim=70)
6754       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6755       double precision zapas(max_dim,maxconts,max_fg_procs),
6756      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6757       common /przechowalnia/ zapas
6758       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6759      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6760 #endif
6761       include 'COMMON.SETUP'
6762       include 'COMMON.FFIELD'
6763       include 'COMMON.DERIV'
6764       include 'COMMON.LOCAL'
6765       include 'COMMON.INTERACT'
6766       include 'COMMON.CONTACTS'
6767       include 'COMMON.CHAIN'
6768       include 'COMMON.CONTROL'
6769       double precision gx(3),gx1(3)
6770       integer num_cont_hb_old(maxres)
6771       logical lprn,ldone
6772       double precision eello4,eello5,eelo6,eello_turn6
6773       external eello4,eello5,eello6,eello_turn6
6774 C Set lprn=.true. for debugging
6775       lprn=.false.
6776       eturn6=0.0d0
6777 #ifdef MPI
6778       do i=1,nres
6779         num_cont_hb_old(i)=num_cont_hb(i)
6780       enddo
6781       n_corr=0
6782       n_corr1=0
6783       if (nfgtasks.le.1) goto 30
6784       if (lprn) then
6785         write (iout,'(a)') 'Contact function values before RECEIVE:'
6786         do i=nnt,nct-2
6787           write (iout,'(2i3,50(1x,i2,f5.2))')
6788      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6789      &    j=1,num_cont_hb(i))
6790         enddo
6791       endif
6792       call flush(iout)
6793       do i=1,ntask_cont_from
6794         ncont_recv(i)=0
6795       enddo
6796       do i=1,ntask_cont_to
6797         ncont_sent(i)=0
6798       enddo
6799 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6800 c     & ntask_cont_to
6801 C Make the list of contacts to send to send to other procesors
6802       do i=iturn3_start,iturn3_end
6803 c        write (iout,*) "make contact list turn3",i," num_cont",
6804 c     &    num_cont_hb(i)
6805         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6806       enddo
6807       do i=iturn4_start,iturn4_end
6808 c        write (iout,*) "make contact list turn4",i," num_cont",
6809 c     &   num_cont_hb(i)
6810         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6811       enddo
6812       do ii=1,nat_sent
6813         i=iat_sent(ii)
6814 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6815 c     &    num_cont_hb(i)
6816         do j=1,num_cont_hb(i)
6817         do k=1,4
6818           jjc=jcont_hb(j,i)
6819           iproc=iint_sent_local(k,jjc,ii)
6820 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6821           if (iproc.ne.0) then
6822             ncont_sent(iproc)=ncont_sent(iproc)+1
6823             nn=ncont_sent(iproc)
6824             zapas(1,nn,iproc)=i
6825             zapas(2,nn,iproc)=jjc
6826             zapas(3,nn,iproc)=d_cont(j,i)
6827             ind=3
6828             do kk=1,3
6829               ind=ind+1
6830               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6831             enddo
6832             do kk=1,2
6833               do ll=1,2
6834                 ind=ind+1
6835                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6836               enddo
6837             enddo
6838             do jj=1,5
6839               do kk=1,3
6840                 do ll=1,2
6841                   do mm=1,2
6842                     ind=ind+1
6843                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6844                   enddo
6845                 enddo
6846               enddo
6847             enddo
6848           endif
6849         enddo
6850         enddo
6851       enddo
6852       if (lprn) then
6853       write (iout,*)
6854      &  "Numbers of contacts to be sent to other processors",
6855      &  (ncont_sent(i),i=1,ntask_cont_to)
6856       write (iout,*) "Contacts sent"
6857       do ii=1,ntask_cont_to
6858         nn=ncont_sent(ii)
6859         iproc=itask_cont_to(ii)
6860         write (iout,*) nn," contacts to processor",iproc,
6861      &   " of CONT_TO_COMM group"
6862         do i=1,nn
6863           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6864         enddo
6865       enddo
6866       call flush(iout)
6867       endif
6868       CorrelType=477
6869       CorrelID=fg_rank+1
6870       CorrelType1=478
6871       CorrelID1=nfgtasks+fg_rank+1
6872       ireq=0
6873 C Receive the numbers of needed contacts from other processors
6874       do ii=1,ntask_cont_from
6875         iproc=itask_cont_from(ii)
6876         ireq=ireq+1
6877         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6878      &    FG_COMM,req(ireq),IERR)
6879       enddo
6880 c      write (iout,*) "IRECV ended"
6881 c      call flush(iout)
6882 C Send the number of contacts needed by other processors
6883       do ii=1,ntask_cont_to
6884         iproc=itask_cont_to(ii)
6885         ireq=ireq+1
6886         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6887      &    FG_COMM,req(ireq),IERR)
6888       enddo
6889 c      write (iout,*) "ISEND ended"
6890 c      write (iout,*) "number of requests (nn)",ireq
6891       call flush(iout)
6892       if (ireq.gt.0)
6893      &  call MPI_Waitall(ireq,req,status_array,ierr)
6894 c      write (iout,*)
6895 c     &  "Numbers of contacts to be received from other processors",
6896 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6897 c      call flush(iout)
6898 C Receive contacts
6899       ireq=0
6900       do ii=1,ntask_cont_from
6901         iproc=itask_cont_from(ii)
6902         nn=ncont_recv(ii)
6903 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6904 c     &   " of CONT_TO_COMM group"
6905         call flush(iout)
6906         if (nn.gt.0) then
6907           ireq=ireq+1
6908           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6909      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6910 c          write (iout,*) "ireq,req",ireq,req(ireq)
6911         endif
6912       enddo
6913 C Send the contacts to processors that need them
6914       do ii=1,ntask_cont_to
6915         iproc=itask_cont_to(ii)
6916         nn=ncont_sent(ii)
6917 c        write (iout,*) nn," contacts to processor",iproc,
6918 c     &   " of CONT_TO_COMM group"
6919         if (nn.gt.0) then
6920           ireq=ireq+1
6921           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6922      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6923 c          write (iout,*) "ireq,req",ireq,req(ireq)
6924 c          do i=1,nn
6925 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6926 c          enddo
6927         endif
6928       enddo
6929 c      write (iout,*) "number of requests (contacts)",ireq
6930 c      write (iout,*) "req",(req(i),i=1,4)
6931 c      call flush(iout)
6932       if (ireq.gt.0)
6933      & call MPI_Waitall(ireq,req,status_array,ierr)
6934       do iii=1,ntask_cont_from
6935         iproc=itask_cont_from(iii)
6936         nn=ncont_recv(iii)
6937         if (lprn) then
6938         write (iout,*) "Received",nn," contacts from processor",iproc,
6939      &   " of CONT_FROM_COMM group"
6940         call flush(iout)
6941         do i=1,nn
6942           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6943         enddo
6944         call flush(iout)
6945         endif
6946         do i=1,nn
6947           ii=zapas_recv(1,i,iii)
6948 c Flag the received contacts to prevent double-counting
6949           jj=-zapas_recv(2,i,iii)
6950 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6951 c          call flush(iout)
6952           nnn=num_cont_hb(ii)+1
6953           num_cont_hb(ii)=nnn
6954           jcont_hb(nnn,ii)=jj
6955           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6956           ind=3
6957           do kk=1,3
6958             ind=ind+1
6959             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6960           enddo
6961           do kk=1,2
6962             do ll=1,2
6963               ind=ind+1
6964               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6965             enddo
6966           enddo
6967           do jj=1,5
6968             do kk=1,3
6969               do ll=1,2
6970                 do mm=1,2
6971                   ind=ind+1
6972                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6973                 enddo
6974               enddo
6975             enddo
6976           enddo
6977         enddo
6978       enddo
6979       call flush(iout)
6980       if (lprn) then
6981         write (iout,'(a)') 'Contact function values after receive:'
6982         do i=nnt,nct-2
6983           write (iout,'(2i3,50(1x,i3,5f6.3))')
6984      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6985      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6986         enddo
6987         call flush(iout)
6988       endif
6989    30 continue
6990 #endif
6991       if (lprn) then
6992         write (iout,'(a)') 'Contact function values:'
6993         do i=nnt,nct-2
6994           write (iout,'(2i3,50(1x,i2,5f6.3))')
6995      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6996      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6997         enddo
6998       endif
6999       ecorr=0.0D0
7000       ecorr5=0.0d0
7001       ecorr6=0.0d0
7002 C Remove the loop below after debugging !!!
7003       do i=nnt,nct
7004         do j=1,3
7005           gradcorr(j,i)=0.0D0
7006           gradxorr(j,i)=0.0D0
7007         enddo
7008       enddo
7009 C Calculate the dipole-dipole interaction energies
7010       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7011       do i=iatel_s,iatel_e+1
7012         num_conti=num_cont_hb(i)
7013         do jj=1,num_conti
7014           j=jcont_hb(jj,i)
7015 #ifdef MOMENT
7016           call dipole(i,j,jj)
7017 #endif
7018         enddo
7019       enddo
7020       endif
7021 C Calculate the local-electrostatic correlation terms
7022 c                write (iout,*) "gradcorr5 in eello5 before loop"
7023 c                do iii=1,nres
7024 c                  write (iout,'(i5,3f10.5)')
7025 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7026 c                enddo
7027       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7028 c        write (iout,*) "corr loop i",i
7029         i1=i+1
7030         num_conti=num_cont_hb(i)
7031         num_conti1=num_cont_hb(i+1)
7032         do jj=1,num_conti
7033           j=jcont_hb(jj,i)
7034           jp=iabs(j)
7035           do kk=1,num_conti1
7036             j1=jcont_hb(kk,i1)
7037             jp1=iabs(j1)
7038 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7039 c     &         ' jj=',jj,' kk=',kk
7040 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7041             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7042      &          .or. j.lt.0 .and. j1.gt.0) .and.
7043      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7044 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7045 C The system gains extra energy.
7046               n_corr=n_corr+1
7047               sqd1=dsqrt(d_cont(jj,i))
7048               sqd2=dsqrt(d_cont(kk,i1))
7049               sred_geom = sqd1*sqd2
7050               IF (sred_geom.lt.cutoff_corr) THEN
7051                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7052      &            ekont,fprimcont)
7053 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7054 cd     &         ' jj=',jj,' kk=',kk
7055                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7056                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7057                 do l=1,3
7058                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7059                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7060                 enddo
7061                 n_corr1=n_corr1+1
7062 cd               write (iout,*) 'sred_geom=',sred_geom,
7063 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7064 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7065 cd               write (iout,*) "g_contij",g_contij
7066 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7067 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7068                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7069                 if (wcorr4.gt.0.0d0)
7070      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7071                   if (energy_dec.and.wcorr4.gt.0.0d0)
7072      1                 write (iout,'(a6,4i5,0pf7.3)')
7073      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7074 c                write (iout,*) "gradcorr5 before eello5"
7075 c                do iii=1,nres
7076 c                  write (iout,'(i5,3f10.5)')
7077 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7078 c                enddo
7079                 if (wcorr5.gt.0.0d0)
7080      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7081 c                write (iout,*) "gradcorr5 after eello5"
7082 c                do iii=1,nres
7083 c                  write (iout,'(i5,3f10.5)')
7084 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7085 c                enddo
7086                   if (energy_dec.and.wcorr5.gt.0.0d0)
7087      1                 write (iout,'(a6,4i5,0pf7.3)')
7088      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7089 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7090 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7091                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7092      &               .or. wturn6.eq.0.0d0))then
7093 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7094                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7095                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7096      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7097 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7098 cd     &            'ecorr6=',ecorr6
7099 cd                write (iout,'(4e15.5)') sred_geom,
7100 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7101 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7102 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7103                 else if (wturn6.gt.0.0d0
7104      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7105 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7106                   eturn6=eturn6+eello_turn6(i,jj,kk)
7107                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7108      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7109 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7110                 endif
7111               ENDIF
7112 1111          continue
7113             endif
7114           enddo ! kk
7115         enddo ! jj
7116       enddo ! i
7117       do i=1,nres
7118         num_cont_hb(i)=num_cont_hb_old(i)
7119       enddo
7120 c                write (iout,*) "gradcorr5 in eello5"
7121 c                do iii=1,nres
7122 c                  write (iout,'(i5,3f10.5)')
7123 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7124 c                enddo
7125       return
7126       end
7127 c------------------------------------------------------------------------------
7128       subroutine add_hb_contact_eello(ii,jj,itask)
7129       implicit real*8 (a-h,o-z)
7130       include "DIMENSIONS"
7131       include "COMMON.IOUNITS"
7132       integer max_cont
7133       integer max_dim
7134       parameter (max_cont=maxconts)
7135       parameter (max_dim=70)
7136       include "COMMON.CONTACTS"
7137       double precision zapas(max_dim,maxconts,max_fg_procs),
7138      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7139       common /przechowalnia/ zapas
7140       integer i,j,ii,jj,iproc,itask(4),nn
7141 c      write (iout,*) "itask",itask
7142       do i=1,2
7143         iproc=itask(i)
7144         if (iproc.gt.0) then
7145           do j=1,num_cont_hb(ii)
7146             jjc=jcont_hb(j,ii)
7147 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7148             if (jjc.eq.jj) then
7149               ncont_sent(iproc)=ncont_sent(iproc)+1
7150               nn=ncont_sent(iproc)
7151               zapas(1,nn,iproc)=ii
7152               zapas(2,nn,iproc)=jjc
7153               zapas(3,nn,iproc)=d_cont(j,ii)
7154               ind=3
7155               do kk=1,3
7156                 ind=ind+1
7157                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7158               enddo
7159               do kk=1,2
7160                 do ll=1,2
7161                   ind=ind+1
7162                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7163                 enddo
7164               enddo
7165               do jj=1,5
7166                 do kk=1,3
7167                   do ll=1,2
7168                     do mm=1,2
7169                       ind=ind+1
7170                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7171                     enddo
7172                   enddo
7173                 enddo
7174               enddo
7175               exit
7176             endif
7177           enddo
7178         endif
7179       enddo
7180       return
7181       end
7182 c------------------------------------------------------------------------------
7183       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7184       implicit real*8 (a-h,o-z)
7185       include 'DIMENSIONS'
7186       include 'COMMON.IOUNITS'
7187       include 'COMMON.DERIV'
7188       include 'COMMON.INTERACT'
7189       include 'COMMON.CONTACTS'
7190       double precision gx(3),gx1(3)
7191       logical lprn
7192       lprn=.false.
7193       eij=facont_hb(jj,i)
7194       ekl=facont_hb(kk,k)
7195       ees0pij=ees0p(jj,i)
7196       ees0pkl=ees0p(kk,k)
7197       ees0mij=ees0m(jj,i)
7198       ees0mkl=ees0m(kk,k)
7199       ekont=eij*ekl
7200       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7201 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7202 C Following 4 lines for diagnostics.
7203 cd    ees0pkl=0.0D0
7204 cd    ees0pij=1.0D0
7205 cd    ees0mkl=0.0D0
7206 cd    ees0mij=1.0D0
7207 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7208 c     & 'Contacts ',i,j,
7209 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7210 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7211 c     & 'gradcorr_long'
7212 C Calculate the multi-body contribution to energy.
7213 c      ecorr=ecorr+ekont*ees
7214 C Calculate multi-body contributions to the gradient.
7215       coeffpees0pij=coeffp*ees0pij
7216       coeffmees0mij=coeffm*ees0mij
7217       coeffpees0pkl=coeffp*ees0pkl
7218       coeffmees0mkl=coeffm*ees0mkl
7219       do ll=1,3
7220 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7221         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7222      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7223      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7224         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7225      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7226      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7227 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7228         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7229      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7230      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7231         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7232      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7233      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7234         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7235      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7236      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7237         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7238         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7239         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7240      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7241      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7242         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7243         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7244 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7245       enddo
7246 c      write (iout,*)
7247 cgrad      do m=i+1,j-1
7248 cgrad        do ll=1,3
7249 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7250 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7251 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7252 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7253 cgrad        enddo
7254 cgrad      enddo
7255 cgrad      do m=k+1,l-1
7256 cgrad        do ll=1,3
7257 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7258 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7259 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7260 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7261 cgrad        enddo
7262 cgrad      enddo
7263 c      write (iout,*) "ehbcorr",ekont*ees
7264       ehbcorr=ekont*ees
7265       return
7266       end
7267 #ifdef MOMENT
7268 C---------------------------------------------------------------------------
7269       subroutine dipole(i,j,jj)
7270       implicit real*8 (a-h,o-z)
7271       include 'DIMENSIONS'
7272       include 'COMMON.IOUNITS'
7273       include 'COMMON.CHAIN'
7274       include 'COMMON.FFIELD'
7275       include 'COMMON.DERIV'
7276       include 'COMMON.INTERACT'
7277       include 'COMMON.CONTACTS'
7278       include 'COMMON.TORSION'
7279       include 'COMMON.VAR'
7280       include 'COMMON.GEO'
7281       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7282      &  auxmat(2,2)
7283       iti1 = itortyp(itype(i+1))
7284       if (j.lt.nres-1) then
7285         itj1 = itortyp(itype(j+1))
7286       else
7287         itj1=ntortyp+1
7288       endif
7289       do iii=1,2
7290         dipi(iii,1)=Ub2(iii,i)
7291         dipderi(iii)=Ub2der(iii,i)
7292         dipi(iii,2)=b1(iii,iti1)
7293         dipj(iii,1)=Ub2(iii,j)
7294         dipderj(iii)=Ub2der(iii,j)
7295         dipj(iii,2)=b1(iii,itj1)
7296       enddo
7297       kkk=0
7298       do iii=1,2
7299         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7300         do jjj=1,2
7301           kkk=kkk+1
7302           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7303         enddo
7304       enddo
7305       do kkk=1,5
7306         do lll=1,3
7307           mmm=0
7308           do iii=1,2
7309             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7310      &        auxvec(1))
7311             do jjj=1,2
7312               mmm=mmm+1
7313               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7314             enddo
7315           enddo
7316         enddo
7317       enddo
7318       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7319       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7320       do iii=1,2
7321         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7322       enddo
7323       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7324       do iii=1,2
7325         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7326       enddo
7327       return
7328       end
7329 #endif
7330 C---------------------------------------------------------------------------
7331       subroutine calc_eello(i,j,k,l,jj,kk)
7332 C
7333 C This subroutine computes matrices and vectors needed to calculate
7334 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7335 C
7336       implicit real*8 (a-h,o-z)
7337       include 'DIMENSIONS'
7338       include 'COMMON.IOUNITS'
7339       include 'COMMON.CHAIN'
7340       include 'COMMON.DERIV'
7341       include 'COMMON.INTERACT'
7342       include 'COMMON.CONTACTS'
7343       include 'COMMON.TORSION'
7344       include 'COMMON.VAR'
7345       include 'COMMON.GEO'
7346       include 'COMMON.FFIELD'
7347       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7348      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7349       logical lprn
7350       common /kutas/ lprn
7351 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7352 cd     & ' jj=',jj,' kk=',kk
7353 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7354 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7355 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7356       do iii=1,2
7357         do jjj=1,2
7358           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7359           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7360         enddo
7361       enddo
7362       call transpose2(aa1(1,1),aa1t(1,1))
7363       call transpose2(aa2(1,1),aa2t(1,1))
7364       do kkk=1,5
7365         do lll=1,3
7366           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7367      &      aa1tder(1,1,lll,kkk))
7368           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7369      &      aa2tder(1,1,lll,kkk))
7370         enddo
7371       enddo
7372       if (l.eq.j+1) then
7373 C parallel orientation of the two CA-CA-CA frames.
7374         if (i.gt.1) then
7375           iti=itortyp(itype(i))
7376         else
7377           iti=ntortyp+1
7378         endif
7379         itk1=itortyp(itype(k+1))
7380         itj=itortyp(itype(j))
7381         if (l.lt.nres-1) then
7382           itl1=itortyp(itype(l+1))
7383         else
7384           itl1=ntortyp+1
7385         endif
7386 C A1 kernel(j+1) A2T
7387 cd        do iii=1,2
7388 cd          write (iout,'(3f10.5,5x,3f10.5)')
7389 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7390 cd        enddo
7391         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7392      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7393      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7394 C Following matrices are needed only for 6-th order cumulants
7395         IF (wcorr6.gt.0.0d0) THEN
7396         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7397      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7398      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7399         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7400      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7401      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7402      &   ADtEAderx(1,1,1,1,1,1))
7403         lprn=.false.
7404         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7405      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7406      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7407      &   ADtEA1derx(1,1,1,1,1,1))
7408         ENDIF
7409 C End 6-th order cumulants
7410 cd        lprn=.false.
7411 cd        if (lprn) then
7412 cd        write (2,*) 'In calc_eello6'
7413 cd        do iii=1,2
7414 cd          write (2,*) 'iii=',iii
7415 cd          do kkk=1,5
7416 cd            write (2,*) 'kkk=',kkk
7417 cd            do jjj=1,2
7418 cd              write (2,'(3(2f10.5),5x)')
7419 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7420 cd            enddo
7421 cd          enddo
7422 cd        enddo
7423 cd        endif
7424         call transpose2(EUgder(1,1,k),auxmat(1,1))
7425         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7426         call transpose2(EUg(1,1,k),auxmat(1,1))
7427         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7428         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7429         do iii=1,2
7430           do kkk=1,5
7431             do lll=1,3
7432               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7433      &          EAEAderx(1,1,lll,kkk,iii,1))
7434             enddo
7435           enddo
7436         enddo
7437 C A1T kernel(i+1) A2
7438         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7439      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7440      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7441 C Following matrices are needed only for 6-th order cumulants
7442         IF (wcorr6.gt.0.0d0) THEN
7443         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7444      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7445      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7446         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7447      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7448      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7449      &   ADtEAderx(1,1,1,1,1,2))
7450         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7451      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7452      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7453      &   ADtEA1derx(1,1,1,1,1,2))
7454         ENDIF
7455 C End 6-th order cumulants
7456         call transpose2(EUgder(1,1,l),auxmat(1,1))
7457         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7458         call transpose2(EUg(1,1,l),auxmat(1,1))
7459         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7460         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7461         do iii=1,2
7462           do kkk=1,5
7463             do lll=1,3
7464               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7465      &          EAEAderx(1,1,lll,kkk,iii,2))
7466             enddo
7467           enddo
7468         enddo
7469 C AEAb1 and AEAb2
7470 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7471 C They are needed only when the fifth- or the sixth-order cumulants are
7472 C indluded.
7473         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7474         call transpose2(AEA(1,1,1),auxmat(1,1))
7475         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7476         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7477         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7478         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7479         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7480         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7481         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7482         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7483         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7484         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7485         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7486         call transpose2(AEA(1,1,2),auxmat(1,1))
7487         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7488         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7489         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7490         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7491         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7492         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7493         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7494         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7495         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7496         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7497         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7498 C Calculate the Cartesian derivatives of the vectors.
7499         do iii=1,2
7500           do kkk=1,5
7501             do lll=1,3
7502               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7503               call matvec2(auxmat(1,1),b1(1,iti),
7504      &          AEAb1derx(1,lll,kkk,iii,1,1))
7505               call matvec2(auxmat(1,1),Ub2(1,i),
7506      &          AEAb2derx(1,lll,kkk,iii,1,1))
7507               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7508      &          AEAb1derx(1,lll,kkk,iii,2,1))
7509               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7510      &          AEAb2derx(1,lll,kkk,iii,2,1))
7511               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7512               call matvec2(auxmat(1,1),b1(1,itj),
7513      &          AEAb1derx(1,lll,kkk,iii,1,2))
7514               call matvec2(auxmat(1,1),Ub2(1,j),
7515      &          AEAb2derx(1,lll,kkk,iii,1,2))
7516               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7517      &          AEAb1derx(1,lll,kkk,iii,2,2))
7518               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7519      &          AEAb2derx(1,lll,kkk,iii,2,2))
7520             enddo
7521           enddo
7522         enddo
7523         ENDIF
7524 C End vectors
7525       else
7526 C Antiparallel orientation of the two CA-CA-CA frames.
7527         if (i.gt.1) then
7528           iti=itortyp(itype(i))
7529         else
7530           iti=ntortyp+1
7531         endif
7532         itk1=itortyp(itype(k+1))
7533         itl=itortyp(itype(l))
7534         itj=itortyp(itype(j))
7535         if (j.lt.nres-1) then
7536           itj1=itortyp(itype(j+1))
7537         else
7538           itj1=ntortyp+1
7539         endif
7540 C A2 kernel(j-1)T A1T
7541         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7542      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7543      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7544 C Following matrices are needed only for 6-th order cumulants
7545         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7546      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7547         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7548      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7549      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7550         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7551      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7552      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7553      &   ADtEAderx(1,1,1,1,1,1))
7554         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7555      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7556      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7557      &   ADtEA1derx(1,1,1,1,1,1))
7558         ENDIF
7559 C End 6-th order cumulants
7560         call transpose2(EUgder(1,1,k),auxmat(1,1))
7561         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7562         call transpose2(EUg(1,1,k),auxmat(1,1))
7563         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7564         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7565         do iii=1,2
7566           do kkk=1,5
7567             do lll=1,3
7568               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7569      &          EAEAderx(1,1,lll,kkk,iii,1))
7570             enddo
7571           enddo
7572         enddo
7573 C A2T kernel(i+1)T A1
7574         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7575      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7576      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7577 C Following matrices are needed only for 6-th order cumulants
7578         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7579      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7580         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7581      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7582      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7583         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7584      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7585      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7586      &   ADtEAderx(1,1,1,1,1,2))
7587         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7588      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7589      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7590      &   ADtEA1derx(1,1,1,1,1,2))
7591         ENDIF
7592 C End 6-th order cumulants
7593         call transpose2(EUgder(1,1,j),auxmat(1,1))
7594         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7595         call transpose2(EUg(1,1,j),auxmat(1,1))
7596         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7597         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7598         do iii=1,2
7599           do kkk=1,5
7600             do lll=1,3
7601               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7602      &          EAEAderx(1,1,lll,kkk,iii,2))
7603             enddo
7604           enddo
7605         enddo
7606 C AEAb1 and AEAb2
7607 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7608 C They are needed only when the fifth- or the sixth-order cumulants are
7609 C indluded.
7610         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7611      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7612         call transpose2(AEA(1,1,1),auxmat(1,1))
7613         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7614         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7615         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7616         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7617         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7618         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7619         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7620         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7621         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7622         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7623         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7624         call transpose2(AEA(1,1,2),auxmat(1,1))
7625         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7626         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7627         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7628         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7629         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7630         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7631         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7632         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7633         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7634         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7635         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7636 C Calculate the Cartesian derivatives of the vectors.
7637         do iii=1,2
7638           do kkk=1,5
7639             do lll=1,3
7640               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7641               call matvec2(auxmat(1,1),b1(1,iti),
7642      &          AEAb1derx(1,lll,kkk,iii,1,1))
7643               call matvec2(auxmat(1,1),Ub2(1,i),
7644      &          AEAb2derx(1,lll,kkk,iii,1,1))
7645               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7646      &          AEAb1derx(1,lll,kkk,iii,2,1))
7647               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7648      &          AEAb2derx(1,lll,kkk,iii,2,1))
7649               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7650               call matvec2(auxmat(1,1),b1(1,itl),
7651      &          AEAb1derx(1,lll,kkk,iii,1,2))
7652               call matvec2(auxmat(1,1),Ub2(1,l),
7653      &          AEAb2derx(1,lll,kkk,iii,1,2))
7654               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7655      &          AEAb1derx(1,lll,kkk,iii,2,2))
7656               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7657      &          AEAb2derx(1,lll,kkk,iii,2,2))
7658             enddo
7659           enddo
7660         enddo
7661         ENDIF
7662 C End vectors
7663       endif
7664       return
7665       end
7666 C---------------------------------------------------------------------------
7667       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7668      &  KK,KKderg,AKA,AKAderg,AKAderx)
7669       implicit none
7670       integer nderg
7671       logical transp
7672       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7673      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7674      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7675       integer iii,kkk,lll
7676       integer jjj,mmm
7677       logical lprn
7678       common /kutas/ lprn
7679       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7680       do iii=1,nderg
7681         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7682      &    AKAderg(1,1,iii))
7683       enddo
7684 cd      if (lprn) write (2,*) 'In kernel'
7685       do kkk=1,5
7686 cd        if (lprn) write (2,*) 'kkk=',kkk
7687         do lll=1,3
7688           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7689      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7690 cd          if (lprn) then
7691 cd            write (2,*) 'lll=',lll
7692 cd            write (2,*) 'iii=1'
7693 cd            do jjj=1,2
7694 cd              write (2,'(3(2f10.5),5x)')
7695 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7696 cd            enddo
7697 cd          endif
7698           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7699      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7700 cd          if (lprn) then
7701 cd            write (2,*) 'lll=',lll
7702 cd            write (2,*) 'iii=2'
7703 cd            do jjj=1,2
7704 cd              write (2,'(3(2f10.5),5x)')
7705 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7706 cd            enddo
7707 cd          endif
7708         enddo
7709       enddo
7710       return
7711       end
7712 C---------------------------------------------------------------------------
7713       double precision function eello4(i,j,k,l,jj,kk)
7714       implicit real*8 (a-h,o-z)
7715       include 'DIMENSIONS'
7716       include 'COMMON.IOUNITS'
7717       include 'COMMON.CHAIN'
7718       include 'COMMON.DERIV'
7719       include 'COMMON.INTERACT'
7720       include 'COMMON.CONTACTS'
7721       include 'COMMON.TORSION'
7722       include 'COMMON.VAR'
7723       include 'COMMON.GEO'
7724       double precision pizda(2,2),ggg1(3),ggg2(3)
7725 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7726 cd        eello4=0.0d0
7727 cd        return
7728 cd      endif
7729 cd      print *,'eello4:',i,j,k,l,jj,kk
7730 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7731 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7732 cold      eij=facont_hb(jj,i)
7733 cold      ekl=facont_hb(kk,k)
7734 cold      ekont=eij*ekl
7735       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7736 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7737       gcorr_loc(k-1)=gcorr_loc(k-1)
7738      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7739       if (l.eq.j+1) then
7740         gcorr_loc(l-1)=gcorr_loc(l-1)
7741      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7742       else
7743         gcorr_loc(j-1)=gcorr_loc(j-1)
7744      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7745       endif
7746       do iii=1,2
7747         do kkk=1,5
7748           do lll=1,3
7749             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7750      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7751 cd            derx(lll,kkk,iii)=0.0d0
7752           enddo
7753         enddo
7754       enddo
7755 cd      gcorr_loc(l-1)=0.0d0
7756 cd      gcorr_loc(j-1)=0.0d0
7757 cd      gcorr_loc(k-1)=0.0d0
7758 cd      eel4=1.0d0
7759 cd      write (iout,*)'Contacts have occurred for peptide groups',
7760 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7761 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7762       if (j.lt.nres-1) then
7763         j1=j+1
7764         j2=j-1
7765       else
7766         j1=j-1
7767         j2=j-2
7768       endif
7769       if (l.lt.nres-1) then
7770         l1=l+1
7771         l2=l-1
7772       else
7773         l1=l-1
7774         l2=l-2
7775       endif
7776       do ll=1,3
7777 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7778 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7779         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7780         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7781 cgrad        ghalf=0.5d0*ggg1(ll)
7782         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7783         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7784         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7785         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7786         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7787         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7788 cgrad        ghalf=0.5d0*ggg2(ll)
7789         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7790         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7791         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7792         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7793         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7794         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7795       enddo
7796 cgrad      do m=i+1,j-1
7797 cgrad        do ll=1,3
7798 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7799 cgrad        enddo
7800 cgrad      enddo
7801 cgrad      do m=k+1,l-1
7802 cgrad        do ll=1,3
7803 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7804 cgrad        enddo
7805 cgrad      enddo
7806 cgrad      do m=i+2,j2
7807 cgrad        do ll=1,3
7808 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7809 cgrad        enddo
7810 cgrad      enddo
7811 cgrad      do m=k+2,l2
7812 cgrad        do ll=1,3
7813 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7814 cgrad        enddo
7815 cgrad      enddo
7816 cd      do iii=1,nres-3
7817 cd        write (2,*) iii,gcorr_loc(iii)
7818 cd      enddo
7819       eello4=ekont*eel4
7820 cd      write (2,*) 'ekont',ekont
7821 cd      write (iout,*) 'eello4',ekont*eel4
7822       return
7823       end
7824 C---------------------------------------------------------------------------
7825       double precision function eello5(i,j,k,l,jj,kk)
7826       implicit real*8 (a-h,o-z)
7827       include 'DIMENSIONS'
7828       include 'COMMON.IOUNITS'
7829       include 'COMMON.CHAIN'
7830       include 'COMMON.DERIV'
7831       include 'COMMON.INTERACT'
7832       include 'COMMON.CONTACTS'
7833       include 'COMMON.TORSION'
7834       include 'COMMON.VAR'
7835       include 'COMMON.GEO'
7836       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7837       double precision ggg1(3),ggg2(3)
7838 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7839 C                                                                              C
7840 C                            Parallel chains                                   C
7841 C                                                                              C
7842 C          o             o                   o             o                   C
7843 C         /l\           / \             \   / \           / \   /              C
7844 C        /   \         /   \             \ /   \         /   \ /               C
7845 C       j| o |l1       | o |              o| o |         | o |o                C
7846 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7847 C      \i/   \         /   \ /             /   \         /   \                 C
7848 C       o    k1             o                                                  C
7849 C         (I)          (II)                (III)          (IV)                 C
7850 C                                                                              C
7851 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7852 C                                                                              C
7853 C                            Antiparallel chains                               C
7854 C                                                                              C
7855 C          o             o                   o             o                   C
7856 C         /j\           / \             \   / \           / \   /              C
7857 C        /   \         /   \             \ /   \         /   \ /               C
7858 C      j1| o |l        | o |              o| o |         | o |o                C
7859 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7860 C      \i/   \         /   \ /             /   \         /   \                 C
7861 C       o     k1            o                                                  C
7862 C         (I)          (II)                (III)          (IV)                 C
7863 C                                                                              C
7864 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7865 C                                                                              C
7866 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7867 C                                                                              C
7868 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7869 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7870 cd        eello5=0.0d0
7871 cd        return
7872 cd      endif
7873 cd      write (iout,*)
7874 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7875 cd     &   ' and',k,l
7876       itk=itortyp(itype(k))
7877       itl=itortyp(itype(l))
7878       itj=itortyp(itype(j))
7879       eello5_1=0.0d0
7880       eello5_2=0.0d0
7881       eello5_3=0.0d0
7882       eello5_4=0.0d0
7883 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7884 cd     &   eel5_3_num,eel5_4_num)
7885       do iii=1,2
7886         do kkk=1,5
7887           do lll=1,3
7888             derx(lll,kkk,iii)=0.0d0
7889           enddo
7890         enddo
7891       enddo
7892 cd      eij=facont_hb(jj,i)
7893 cd      ekl=facont_hb(kk,k)
7894 cd      ekont=eij*ekl
7895 cd      write (iout,*)'Contacts have occurred for peptide groups',
7896 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7897 cd      goto 1111
7898 C Contribution from the graph I.
7899 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7900 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7901       call transpose2(EUg(1,1,k),auxmat(1,1))
7902       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7903       vv(1)=pizda(1,1)-pizda(2,2)
7904       vv(2)=pizda(1,2)+pizda(2,1)
7905       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7906      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7907 C Explicit gradient in virtual-dihedral angles.
7908       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7909      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7910      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7911       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7912       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7913       vv(1)=pizda(1,1)-pizda(2,2)
7914       vv(2)=pizda(1,2)+pizda(2,1)
7915       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7916      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7917      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7918       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7919       vv(1)=pizda(1,1)-pizda(2,2)
7920       vv(2)=pizda(1,2)+pizda(2,1)
7921       if (l.eq.j+1) then
7922         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7923      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7924      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7925       else
7926         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7927      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7928      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7929       endif
7930 C Cartesian gradient
7931       do iii=1,2
7932         do kkk=1,5
7933           do lll=1,3
7934             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7935      &        pizda(1,1))
7936             vv(1)=pizda(1,1)-pizda(2,2)
7937             vv(2)=pizda(1,2)+pizda(2,1)
7938             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7939      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7940      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7941           enddo
7942         enddo
7943       enddo
7944 c      goto 1112
7945 c1111  continue
7946 C Contribution from graph II
7947       call transpose2(EE(1,1,itk),auxmat(1,1))
7948       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7949       vv(1)=pizda(1,1)+pizda(2,2)
7950       vv(2)=pizda(2,1)-pizda(1,2)
7951       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7952      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7953 C Explicit gradient in virtual-dihedral angles.
7954       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7955      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7956       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7957       vv(1)=pizda(1,1)+pizda(2,2)
7958       vv(2)=pizda(2,1)-pizda(1,2)
7959       if (l.eq.j+1) then
7960         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7961      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7962      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7963       else
7964         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7965      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7966      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7967       endif
7968 C Cartesian gradient
7969       do iii=1,2
7970         do kkk=1,5
7971           do lll=1,3
7972             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7973      &        pizda(1,1))
7974             vv(1)=pizda(1,1)+pizda(2,2)
7975             vv(2)=pizda(2,1)-pizda(1,2)
7976             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7977      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7978      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7979           enddo
7980         enddo
7981       enddo
7982 cd      goto 1112
7983 cd1111  continue
7984       if (l.eq.j+1) then
7985 cd        goto 1110
7986 C Parallel orientation
7987 C Contribution from graph III
7988         call transpose2(EUg(1,1,l),auxmat(1,1))
7989         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7990         vv(1)=pizda(1,1)-pizda(2,2)
7991         vv(2)=pizda(1,2)+pizda(2,1)
7992         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7993      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7994 C Explicit gradient in virtual-dihedral angles.
7995         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7996      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7997      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7998         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7999         vv(1)=pizda(1,1)-pizda(2,2)
8000         vv(2)=pizda(1,2)+pizda(2,1)
8001         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8002      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8003      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8004         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8005         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8006         vv(1)=pizda(1,1)-pizda(2,2)
8007         vv(2)=pizda(1,2)+pizda(2,1)
8008         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8009      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8010      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8011 C Cartesian gradient
8012         do iii=1,2
8013           do kkk=1,5
8014             do lll=1,3
8015               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8016      &          pizda(1,1))
8017               vv(1)=pizda(1,1)-pizda(2,2)
8018               vv(2)=pizda(1,2)+pizda(2,1)
8019               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8020      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8021      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8022             enddo
8023           enddo
8024         enddo
8025 cd        goto 1112
8026 C Contribution from graph IV
8027 cd1110    continue
8028         call transpose2(EE(1,1,itl),auxmat(1,1))
8029         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8030         vv(1)=pizda(1,1)+pizda(2,2)
8031         vv(2)=pizda(2,1)-pizda(1,2)
8032         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8033      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8034 C Explicit gradient in virtual-dihedral angles.
8035         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8036      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8037         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8038         vv(1)=pizda(1,1)+pizda(2,2)
8039         vv(2)=pizda(2,1)-pizda(1,2)
8040         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8041      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8042      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8043 C Cartesian gradient
8044         do iii=1,2
8045           do kkk=1,5
8046             do lll=1,3
8047               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8048      &          pizda(1,1))
8049               vv(1)=pizda(1,1)+pizda(2,2)
8050               vv(2)=pizda(2,1)-pizda(1,2)
8051               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8052      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8053      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8054             enddo
8055           enddo
8056         enddo
8057       else
8058 C Antiparallel orientation
8059 C Contribution from graph III
8060 c        goto 1110
8061         call transpose2(EUg(1,1,j),auxmat(1,1))
8062         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8063         vv(1)=pizda(1,1)-pizda(2,2)
8064         vv(2)=pizda(1,2)+pizda(2,1)
8065         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8066      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8067 C Explicit gradient in virtual-dihedral angles.
8068         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8069      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8070      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8071         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8072         vv(1)=pizda(1,1)-pizda(2,2)
8073         vv(2)=pizda(1,2)+pizda(2,1)
8074         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8075      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8076      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8077         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8078         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8079         vv(1)=pizda(1,1)-pizda(2,2)
8080         vv(2)=pizda(1,2)+pizda(2,1)
8081         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8082      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8083      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8084 C Cartesian gradient
8085         do iii=1,2
8086           do kkk=1,5
8087             do lll=1,3
8088               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8089      &          pizda(1,1))
8090               vv(1)=pizda(1,1)-pizda(2,2)
8091               vv(2)=pizda(1,2)+pizda(2,1)
8092               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8093      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8094      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8095             enddo
8096           enddo
8097         enddo
8098 cd        goto 1112
8099 C Contribution from graph IV
8100 1110    continue
8101         call transpose2(EE(1,1,itj),auxmat(1,1))
8102         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8103         vv(1)=pizda(1,1)+pizda(2,2)
8104         vv(2)=pizda(2,1)-pizda(1,2)
8105         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8106      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8107 C Explicit gradient in virtual-dihedral angles.
8108         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8109      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8110         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8111         vv(1)=pizda(1,1)+pizda(2,2)
8112         vv(2)=pizda(2,1)-pizda(1,2)
8113         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8114      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8115      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8116 C Cartesian gradient
8117         do iii=1,2
8118           do kkk=1,5
8119             do lll=1,3
8120               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8121      &          pizda(1,1))
8122               vv(1)=pizda(1,1)+pizda(2,2)
8123               vv(2)=pizda(2,1)-pizda(1,2)
8124               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8125      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8126      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8127             enddo
8128           enddo
8129         enddo
8130       endif
8131 1112  continue
8132       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8133 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8134 cd        write (2,*) 'ijkl',i,j,k,l
8135 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8136 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8137 cd      endif
8138 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8139 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8140 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8141 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8142       if (j.lt.nres-1) then
8143         j1=j+1
8144         j2=j-1
8145       else
8146         j1=j-1
8147         j2=j-2
8148       endif
8149       if (l.lt.nres-1) then
8150         l1=l+1
8151         l2=l-1
8152       else
8153         l1=l-1
8154         l2=l-2
8155       endif
8156 cd      eij=1.0d0
8157 cd      ekl=1.0d0
8158 cd      ekont=1.0d0
8159 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8160 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8161 C        summed up outside the subrouine as for the other subroutines
8162 C        handling long-range interactions. The old code is commented out
8163 C        with "cgrad" to keep track of changes.
8164       do ll=1,3
8165 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8166 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8167         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8168         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8169 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8170 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8171 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8172 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8173 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8174 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8175 c     &   gradcorr5ij,
8176 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8177 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8178 cgrad        ghalf=0.5d0*ggg1(ll)
8179 cd        ghalf=0.0d0
8180         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8181         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8182         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8183         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8184         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8185         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8186 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8187 cgrad        ghalf=0.5d0*ggg2(ll)
8188 cd        ghalf=0.0d0
8189         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8190         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8191         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8192         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8193         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8194         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8195       enddo
8196 cd      goto 1112
8197 cgrad      do m=i+1,j-1
8198 cgrad        do ll=1,3
8199 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8200 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8201 cgrad        enddo
8202 cgrad      enddo
8203 cgrad      do m=k+1,l-1
8204 cgrad        do ll=1,3
8205 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8206 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8207 cgrad        enddo
8208 cgrad      enddo
8209 c1112  continue
8210 cgrad      do m=i+2,j2
8211 cgrad        do ll=1,3
8212 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8213 cgrad        enddo
8214 cgrad      enddo
8215 cgrad      do m=k+2,l2
8216 cgrad        do ll=1,3
8217 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8218 cgrad        enddo
8219 cgrad      enddo
8220 cd      do iii=1,nres-3
8221 cd        write (2,*) iii,g_corr5_loc(iii)
8222 cd      enddo
8223       eello5=ekont*eel5
8224 cd      write (2,*) 'ekont',ekont
8225 cd      write (iout,*) 'eello5',ekont*eel5
8226       return
8227       end
8228 c--------------------------------------------------------------------------
8229       double precision function eello6(i,j,k,l,jj,kk)
8230       implicit real*8 (a-h,o-z)
8231       include 'DIMENSIONS'
8232       include 'COMMON.IOUNITS'
8233       include 'COMMON.CHAIN'
8234       include 'COMMON.DERIV'
8235       include 'COMMON.INTERACT'
8236       include 'COMMON.CONTACTS'
8237       include 'COMMON.TORSION'
8238       include 'COMMON.VAR'
8239       include 'COMMON.GEO'
8240       include 'COMMON.FFIELD'
8241       double precision ggg1(3),ggg2(3)
8242 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8243 cd        eello6=0.0d0
8244 cd        return
8245 cd      endif
8246 cd      write (iout,*)
8247 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8248 cd     &   ' and',k,l
8249       eello6_1=0.0d0
8250       eello6_2=0.0d0
8251       eello6_3=0.0d0
8252       eello6_4=0.0d0
8253       eello6_5=0.0d0
8254       eello6_6=0.0d0
8255 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8256 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8257       do iii=1,2
8258         do kkk=1,5
8259           do lll=1,3
8260             derx(lll,kkk,iii)=0.0d0
8261           enddo
8262         enddo
8263       enddo
8264 cd      eij=facont_hb(jj,i)
8265 cd      ekl=facont_hb(kk,k)
8266 cd      ekont=eij*ekl
8267 cd      eij=1.0d0
8268 cd      ekl=1.0d0
8269 cd      ekont=1.0d0
8270       if (l.eq.j+1) then
8271         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8272         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8273         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8274         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8275         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8276         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8277       else
8278         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8279         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8280         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8281         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8282         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8283           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8284         else
8285           eello6_5=0.0d0
8286         endif
8287         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8288       endif
8289 C If turn contributions are considered, they will be handled separately.
8290       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8291 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8292 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8293 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8294 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8295 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8296 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8297 cd      goto 1112
8298       if (j.lt.nres-1) then
8299         j1=j+1
8300         j2=j-1
8301       else
8302         j1=j-1
8303         j2=j-2
8304       endif
8305       if (l.lt.nres-1) then
8306         l1=l+1
8307         l2=l-1
8308       else
8309         l1=l-1
8310         l2=l-2
8311       endif
8312       do ll=1,3
8313 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8314 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8315 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8316 cgrad        ghalf=0.5d0*ggg1(ll)
8317 cd        ghalf=0.0d0
8318         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8319         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8320         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8321         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8322         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8323         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8324         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8325         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8326 cgrad        ghalf=0.5d0*ggg2(ll)
8327 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8328 cd        ghalf=0.0d0
8329         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8330         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8331         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8332         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8333         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8334         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8335       enddo
8336 cd      goto 1112
8337 cgrad      do m=i+1,j-1
8338 cgrad        do ll=1,3
8339 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8340 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8341 cgrad        enddo
8342 cgrad      enddo
8343 cgrad      do m=k+1,l-1
8344 cgrad        do ll=1,3
8345 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8346 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8347 cgrad        enddo
8348 cgrad      enddo
8349 cgrad1112  continue
8350 cgrad      do m=i+2,j2
8351 cgrad        do ll=1,3
8352 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8353 cgrad        enddo
8354 cgrad      enddo
8355 cgrad      do m=k+2,l2
8356 cgrad        do ll=1,3
8357 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8358 cgrad        enddo
8359 cgrad      enddo
8360 cd      do iii=1,nres-3
8361 cd        write (2,*) iii,g_corr6_loc(iii)
8362 cd      enddo
8363       eello6=ekont*eel6
8364 cd      write (2,*) 'ekont',ekont
8365 cd      write (iout,*) 'eello6',ekont*eel6
8366       return
8367       end
8368 c--------------------------------------------------------------------------
8369       double precision function eello6_graph1(i,j,k,l,imat,swap)
8370       implicit real*8 (a-h,o-z)
8371       include 'DIMENSIONS'
8372       include 'COMMON.IOUNITS'
8373       include 'COMMON.CHAIN'
8374       include 'COMMON.DERIV'
8375       include 'COMMON.INTERACT'
8376       include 'COMMON.CONTACTS'
8377       include 'COMMON.TORSION'
8378       include 'COMMON.VAR'
8379       include 'COMMON.GEO'
8380       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8381       logical swap
8382       logical lprn
8383       common /kutas/ lprn
8384 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8385 C
8386 C      Parallel       Antiparallel
8387 C
8388 C          o             o
8389 C         /l\           /j\
8390 C        /   \         /   \
8391 C       /| o |         | o |\
8392 C     \ j|/k\|  /   \  |/k\|l /
8393 C      \ /   \ /     \ /   \ /
8394 C       o     o       o     o
8395 C       i             i
8396 C
8397 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8398       itk=itortyp(itype(k))
8399       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8400       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8401       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8402       call transpose2(EUgC(1,1,k),auxmat(1,1))
8403       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8404       vv1(1)=pizda1(1,1)-pizda1(2,2)
8405       vv1(2)=pizda1(1,2)+pizda1(2,1)
8406       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8407       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8408       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8409       s5=scalar2(vv(1),Dtobr2(1,i))
8410 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8411       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8412       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8413      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8414      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8415      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8416      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8417      & +scalar2(vv(1),Dtobr2der(1,i)))
8418       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8419       vv1(1)=pizda1(1,1)-pizda1(2,2)
8420       vv1(2)=pizda1(1,2)+pizda1(2,1)
8421       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8422       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8423       if (l.eq.j+1) then
8424         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8425      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8426      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8427      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8428      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8429       else
8430         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8431      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8432      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8433      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8434      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8435       endif
8436       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8437       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8438       vv1(1)=pizda1(1,1)-pizda1(2,2)
8439       vv1(2)=pizda1(1,2)+pizda1(2,1)
8440       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8441      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8442      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8443      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8444       do iii=1,2
8445         if (swap) then
8446           ind=3-iii
8447         else
8448           ind=iii
8449         endif
8450         do kkk=1,5
8451           do lll=1,3
8452             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8453             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8454             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8455             call transpose2(EUgC(1,1,k),auxmat(1,1))
8456             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8457      &        pizda1(1,1))
8458             vv1(1)=pizda1(1,1)-pizda1(2,2)
8459             vv1(2)=pizda1(1,2)+pizda1(2,1)
8460             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8461             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8462      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8463             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8464      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8465             s5=scalar2(vv(1),Dtobr2(1,i))
8466             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8467           enddo
8468         enddo
8469       enddo
8470       return
8471       end
8472 c----------------------------------------------------------------------------
8473       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8474       implicit real*8 (a-h,o-z)
8475       include 'DIMENSIONS'
8476       include 'COMMON.IOUNITS'
8477       include 'COMMON.CHAIN'
8478       include 'COMMON.DERIV'
8479       include 'COMMON.INTERACT'
8480       include 'COMMON.CONTACTS'
8481       include 'COMMON.TORSION'
8482       include 'COMMON.VAR'
8483       include 'COMMON.GEO'
8484       logical swap
8485       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8486      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8487       logical lprn
8488       common /kutas/ lprn
8489 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8490 C                                                                              C
8491 C      Parallel       Antiparallel                                             C
8492 C                                                                              C
8493 C          o             o                                                     C
8494 C     \   /l\           /j\   /                                                C
8495 C      \ /   \         /   \ /                                                 C
8496 C       o| o |         | o |o                                                  C
8497 C     \ j|/k\|      \  |/k\|l                                                  C
8498 C      \ /   \       \ /   \                                                   C
8499 C       o             o                                                        C
8500 C       i             i                                                        C
8501 C                                                                              C
8502 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8503 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8504 C AL 7/4/01 s1 would occur in the sixth-order moment,
8505 C           but not in a cluster cumulant
8506 #ifdef MOMENT
8507       s1=dip(1,jj,i)*dip(1,kk,k)
8508 #endif
8509       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8510       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8511       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8512       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8513       call transpose2(EUg(1,1,k),auxmat(1,1))
8514       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8515       vv(1)=pizda(1,1)-pizda(2,2)
8516       vv(2)=pizda(1,2)+pizda(2,1)
8517       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8518 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8519 #ifdef MOMENT
8520       eello6_graph2=-(s1+s2+s3+s4)
8521 #else
8522       eello6_graph2=-(s2+s3+s4)
8523 #endif
8524 c      eello6_graph2=-s3
8525 C Derivatives in gamma(i-1)
8526       if (i.gt.1) then
8527 #ifdef MOMENT
8528         s1=dipderg(1,jj,i)*dip(1,kk,k)
8529 #endif
8530         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8531         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8532         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8533         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8534 #ifdef MOMENT
8535         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8536 #else
8537         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8538 #endif
8539 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8540       endif
8541 C Derivatives in gamma(k-1)
8542 #ifdef MOMENT
8543       s1=dip(1,jj,i)*dipderg(1,kk,k)
8544 #endif
8545       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8546       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8547       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8548       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8549       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8550       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8551       vv(1)=pizda(1,1)-pizda(2,2)
8552       vv(2)=pizda(1,2)+pizda(2,1)
8553       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8554 #ifdef MOMENT
8555       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8556 #else
8557       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8558 #endif
8559 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8560 C Derivatives in gamma(j-1) or gamma(l-1)
8561       if (j.gt.1) then
8562 #ifdef MOMENT
8563         s1=dipderg(3,jj,i)*dip(1,kk,k)
8564 #endif
8565         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8566         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8567         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8568         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8569         vv(1)=pizda(1,1)-pizda(2,2)
8570         vv(2)=pizda(1,2)+pizda(2,1)
8571         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8572 #ifdef MOMENT
8573         if (swap) then
8574           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8575         else
8576           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8577         endif
8578 #endif
8579         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8580 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8581       endif
8582 C Derivatives in gamma(l-1) or gamma(j-1)
8583       if (l.gt.1) then
8584 #ifdef MOMENT
8585         s1=dip(1,jj,i)*dipderg(3,kk,k)
8586 #endif
8587         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8588         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8589         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8590         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8591         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8592         vv(1)=pizda(1,1)-pizda(2,2)
8593         vv(2)=pizda(1,2)+pizda(2,1)
8594         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8595 #ifdef MOMENT
8596         if (swap) then
8597           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8598         else
8599           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8600         endif
8601 #endif
8602         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8603 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8604       endif
8605 C Cartesian derivatives.
8606       if (lprn) then
8607         write (2,*) 'In eello6_graph2'
8608         do iii=1,2
8609           write (2,*) 'iii=',iii
8610           do kkk=1,5
8611             write (2,*) 'kkk=',kkk
8612             do jjj=1,2
8613               write (2,'(3(2f10.5),5x)')
8614      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8615             enddo
8616           enddo
8617         enddo
8618       endif
8619       do iii=1,2
8620         do kkk=1,5
8621           do lll=1,3
8622 #ifdef MOMENT
8623             if (iii.eq.1) then
8624               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8625             else
8626               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8627             endif
8628 #endif
8629             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8630      &        auxvec(1))
8631             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8632             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8633      &        auxvec(1))
8634             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8635             call transpose2(EUg(1,1,k),auxmat(1,1))
8636             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8637      &        pizda(1,1))
8638             vv(1)=pizda(1,1)-pizda(2,2)
8639             vv(2)=pizda(1,2)+pizda(2,1)
8640             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8641 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8642 #ifdef MOMENT
8643             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8644 #else
8645             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8646 #endif
8647             if (swap) then
8648               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8649             else
8650               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8651             endif
8652           enddo
8653         enddo
8654       enddo
8655       return
8656       end
8657 c----------------------------------------------------------------------------
8658       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8659       implicit real*8 (a-h,o-z)
8660       include 'DIMENSIONS'
8661       include 'COMMON.IOUNITS'
8662       include 'COMMON.CHAIN'
8663       include 'COMMON.DERIV'
8664       include 'COMMON.INTERACT'
8665       include 'COMMON.CONTACTS'
8666       include 'COMMON.TORSION'
8667       include 'COMMON.VAR'
8668       include 'COMMON.GEO'
8669       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8670       logical swap
8671 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8672 C                                                                              C
8673 C      Parallel       Antiparallel                                             C
8674 C                                                                              C
8675 C          o             o                                                     C
8676 C         /l\   /   \   /j\                                                    C
8677 C        /   \ /     \ /   \                                                   C
8678 C       /| o |o       o| o |\                                                  C
8679 C       j|/k\|  /      |/k\|l /                                                C
8680 C        /   \ /       /   \ /                                                 C
8681 C       /     o       /     o                                                  C
8682 C       i             i                                                        C
8683 C                                                                              C
8684 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8685 C
8686 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8687 C           energy moment and not to the cluster cumulant.
8688       iti=itortyp(itype(i))
8689       if (j.lt.nres-1) then
8690         itj1=itortyp(itype(j+1))
8691       else
8692         itj1=ntortyp+1
8693       endif
8694       itk=itortyp(itype(k))
8695       itk1=itortyp(itype(k+1))
8696       if (l.lt.nres-1) then
8697         itl1=itortyp(itype(l+1))
8698       else
8699         itl1=ntortyp+1
8700       endif
8701 #ifdef MOMENT
8702       s1=dip(4,jj,i)*dip(4,kk,k)
8703 #endif
8704       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8705       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8706       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8707       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8708       call transpose2(EE(1,1,itk),auxmat(1,1))
8709       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8710       vv(1)=pizda(1,1)+pizda(2,2)
8711       vv(2)=pizda(2,1)-pizda(1,2)
8712       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8713 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8714 cd     & "sum",-(s2+s3+s4)
8715 #ifdef MOMENT
8716       eello6_graph3=-(s1+s2+s3+s4)
8717 #else
8718       eello6_graph3=-(s2+s3+s4)
8719 #endif
8720 c      eello6_graph3=-s4
8721 C Derivatives in gamma(k-1)
8722       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8723       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8724       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8725       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8726 C Derivatives in gamma(l-1)
8727       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8728       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8729       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8730       vv(1)=pizda(1,1)+pizda(2,2)
8731       vv(2)=pizda(2,1)-pizda(1,2)
8732       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8733       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8734 C Cartesian derivatives.
8735       do iii=1,2
8736         do kkk=1,5
8737           do lll=1,3
8738 #ifdef MOMENT
8739             if (iii.eq.1) then
8740               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8741             else
8742               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8743             endif
8744 #endif
8745             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8746      &        auxvec(1))
8747             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8748             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8749      &        auxvec(1))
8750             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8751             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8752      &        pizda(1,1))
8753             vv(1)=pizda(1,1)+pizda(2,2)
8754             vv(2)=pizda(2,1)-pizda(1,2)
8755             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8756 #ifdef MOMENT
8757             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8758 #else
8759             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8760 #endif
8761             if (swap) then
8762               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8763             else
8764               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8765             endif
8766 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8767           enddo
8768         enddo
8769       enddo
8770       return
8771       end
8772 c----------------------------------------------------------------------------
8773       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8774       implicit real*8 (a-h,o-z)
8775       include 'DIMENSIONS'
8776       include 'COMMON.IOUNITS'
8777       include 'COMMON.CHAIN'
8778       include 'COMMON.DERIV'
8779       include 'COMMON.INTERACT'
8780       include 'COMMON.CONTACTS'
8781       include 'COMMON.TORSION'
8782       include 'COMMON.VAR'
8783       include 'COMMON.GEO'
8784       include 'COMMON.FFIELD'
8785       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8786      & auxvec1(2),auxmat1(2,2)
8787       logical swap
8788 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8789 C                                                                              C
8790 C      Parallel       Antiparallel                                             C
8791 C                                                                              C
8792 C          o             o                                                     C
8793 C         /l\   /   \   /j\                                                    C
8794 C        /   \ /     \ /   \                                                   C
8795 C       /| o |o       o| o |\                                                  C
8796 C     \ j|/k\|      \  |/k\|l                                                  C
8797 C      \ /   \       \ /   \                                                   C
8798 C       o     \       o     \                                                  C
8799 C       i             i                                                        C
8800 C                                                                              C
8801 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8802 C
8803 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8804 C           energy moment and not to the cluster cumulant.
8805 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8806       iti=itortyp(itype(i))
8807       itj=itortyp(itype(j))
8808       if (j.lt.nres-1) then
8809         itj1=itortyp(itype(j+1))
8810       else
8811         itj1=ntortyp+1
8812       endif
8813       itk=itortyp(itype(k))
8814       if (k.lt.nres-1) then
8815         itk1=itortyp(itype(k+1))
8816       else
8817         itk1=ntortyp+1
8818       endif
8819       itl=itortyp(itype(l))
8820       if (l.lt.nres-1) then
8821         itl1=itortyp(itype(l+1))
8822       else
8823         itl1=ntortyp+1
8824       endif
8825 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8826 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8827 cd     & ' itl',itl,' itl1',itl1
8828 #ifdef MOMENT
8829       if (imat.eq.1) then
8830         s1=dip(3,jj,i)*dip(3,kk,k)
8831       else
8832         s1=dip(2,jj,j)*dip(2,kk,l)
8833       endif
8834 #endif
8835       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8836       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8837       if (j.eq.l+1) then
8838         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8839         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8840       else
8841         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8842         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8843       endif
8844       call transpose2(EUg(1,1,k),auxmat(1,1))
8845       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8846       vv(1)=pizda(1,1)-pizda(2,2)
8847       vv(2)=pizda(2,1)+pizda(1,2)
8848       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8849 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8850 #ifdef MOMENT
8851       eello6_graph4=-(s1+s2+s3+s4)
8852 #else
8853       eello6_graph4=-(s2+s3+s4)
8854 #endif
8855 C Derivatives in gamma(i-1)
8856       if (i.gt.1) then
8857 #ifdef MOMENT
8858         if (imat.eq.1) then
8859           s1=dipderg(2,jj,i)*dip(3,kk,k)
8860         else
8861           s1=dipderg(4,jj,j)*dip(2,kk,l)
8862         endif
8863 #endif
8864         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8865         if (j.eq.l+1) then
8866           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8867           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8868         else
8869           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8870           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8871         endif
8872         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8873         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8874 cd          write (2,*) 'turn6 derivatives'
8875 #ifdef MOMENT
8876           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8877 #else
8878           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8879 #endif
8880         else
8881 #ifdef MOMENT
8882           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8883 #else
8884           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8885 #endif
8886         endif
8887       endif
8888 C Derivatives in gamma(k-1)
8889 #ifdef MOMENT
8890       if (imat.eq.1) then
8891         s1=dip(3,jj,i)*dipderg(2,kk,k)
8892       else
8893         s1=dip(2,jj,j)*dipderg(4,kk,l)
8894       endif
8895 #endif
8896       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8897       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8898       if (j.eq.l+1) then
8899         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8900         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8901       else
8902         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8903         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8904       endif
8905       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8906       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8907       vv(1)=pizda(1,1)-pizda(2,2)
8908       vv(2)=pizda(2,1)+pizda(1,2)
8909       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8910       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8911 #ifdef MOMENT
8912         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8913 #else
8914         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8915 #endif
8916       else
8917 #ifdef MOMENT
8918         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8919 #else
8920         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8921 #endif
8922       endif
8923 C Derivatives in gamma(j-1) or gamma(l-1)
8924       if (l.eq.j+1 .and. l.gt.1) then
8925         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8926         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8927         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8928         vv(1)=pizda(1,1)-pizda(2,2)
8929         vv(2)=pizda(2,1)+pizda(1,2)
8930         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8931         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8932       else if (j.gt.1) then
8933         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8934         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8935         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8936         vv(1)=pizda(1,1)-pizda(2,2)
8937         vv(2)=pizda(2,1)+pizda(1,2)
8938         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8939         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8940           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8941         else
8942           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8943         endif
8944       endif
8945 C Cartesian derivatives.
8946       do iii=1,2
8947         do kkk=1,5
8948           do lll=1,3
8949 #ifdef MOMENT
8950             if (iii.eq.1) then
8951               if (imat.eq.1) then
8952                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8953               else
8954                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8955               endif
8956             else
8957               if (imat.eq.1) then
8958                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8959               else
8960                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8961               endif
8962             endif
8963 #endif
8964             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8965      &        auxvec(1))
8966             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8967             if (j.eq.l+1) then
8968               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8969      &          b1(1,itj1),auxvec(1))
8970               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8971             else
8972               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8973      &          b1(1,itl1),auxvec(1))
8974               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8975             endif
8976             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8977      &        pizda(1,1))
8978             vv(1)=pizda(1,1)-pizda(2,2)
8979             vv(2)=pizda(2,1)+pizda(1,2)
8980             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8981             if (swap) then
8982               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8983 #ifdef MOMENT
8984                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8985      &             -(s1+s2+s4)
8986 #else
8987                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8988      &             -(s2+s4)
8989 #endif
8990                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8991               else
8992 #ifdef MOMENT
8993                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8994 #else
8995                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8996 #endif
8997                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8998               endif
8999             else
9000 #ifdef MOMENT
9001               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9002 #else
9003               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9004 #endif
9005               if (l.eq.j+1) then
9006                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9007               else
9008                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9009               endif
9010             endif
9011           enddo
9012         enddo
9013       enddo
9014       return
9015       end
9016 c----------------------------------------------------------------------------
9017       double precision function eello_turn6(i,jj,kk)
9018       implicit real*8 (a-h,o-z)
9019       include 'DIMENSIONS'
9020       include 'COMMON.IOUNITS'
9021       include 'COMMON.CHAIN'
9022       include 'COMMON.DERIV'
9023       include 'COMMON.INTERACT'
9024       include 'COMMON.CONTACTS'
9025       include 'COMMON.TORSION'
9026       include 'COMMON.VAR'
9027       include 'COMMON.GEO'
9028       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9029      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9030      &  ggg1(3),ggg2(3)
9031       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9032      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9033 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9034 C           the respective energy moment and not to the cluster cumulant.
9035       s1=0.0d0
9036       s8=0.0d0
9037       s13=0.0d0
9038 c
9039       eello_turn6=0.0d0
9040       j=i+4
9041       k=i+1
9042       l=i+3
9043       iti=itortyp(itype(i))
9044       itk=itortyp(itype(k))
9045       itk1=itortyp(itype(k+1))
9046       itl=itortyp(itype(l))
9047       itj=itortyp(itype(j))
9048 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9049 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9050 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9051 cd        eello6=0.0d0
9052 cd        return
9053 cd      endif
9054 cd      write (iout,*)
9055 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9056 cd     &   ' and',k,l
9057 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9058       do iii=1,2
9059         do kkk=1,5
9060           do lll=1,3
9061             derx_turn(lll,kkk,iii)=0.0d0
9062           enddo
9063         enddo
9064       enddo
9065 cd      eij=1.0d0
9066 cd      ekl=1.0d0
9067 cd      ekont=1.0d0
9068       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9069 cd      eello6_5=0.0d0
9070 cd      write (2,*) 'eello6_5',eello6_5
9071 #ifdef MOMENT
9072       call transpose2(AEA(1,1,1),auxmat(1,1))
9073       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9074       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9075       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9076 #endif
9077       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9078       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9079       s2 = scalar2(b1(1,itk),vtemp1(1))
9080 #ifdef MOMENT
9081       call transpose2(AEA(1,1,2),atemp(1,1))
9082       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9083       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9084       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9085 #endif
9086       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9087       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9088       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9089 #ifdef MOMENT
9090       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9091       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9092       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9093       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9094       ss13 = scalar2(b1(1,itk),vtemp4(1))
9095       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9096 #endif
9097 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9098 c      s1=0.0d0
9099 c      s2=0.0d0
9100 c      s8=0.0d0
9101 c      s12=0.0d0
9102 c      s13=0.0d0
9103       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9104 C Derivatives in gamma(i+2)
9105       s1d =0.0d0
9106       s8d =0.0d0
9107 #ifdef MOMENT
9108       call transpose2(AEA(1,1,1),auxmatd(1,1))
9109       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9110       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9111       call transpose2(AEAderg(1,1,2),atempd(1,1))
9112       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9113       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9114 #endif
9115       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9116       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9117       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9118 c      s1d=0.0d0
9119 c      s2d=0.0d0
9120 c      s8d=0.0d0
9121 c      s12d=0.0d0
9122 c      s13d=0.0d0
9123       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9124 C Derivatives in gamma(i+3)
9125 #ifdef MOMENT
9126       call transpose2(AEA(1,1,1),auxmatd(1,1))
9127       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9128       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9129       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9130 #endif
9131       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9132       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9133       s2d = scalar2(b1(1,itk),vtemp1d(1))
9134 #ifdef MOMENT
9135       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9136       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9137 #endif
9138       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9139 #ifdef MOMENT
9140       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9141       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9142       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9143 #endif
9144 c      s1d=0.0d0
9145 c      s2d=0.0d0
9146 c      s8d=0.0d0
9147 c      s12d=0.0d0
9148 c      s13d=0.0d0
9149 #ifdef MOMENT
9150       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9151      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9152 #else
9153       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9154      &               -0.5d0*ekont*(s2d+s12d)
9155 #endif
9156 C Derivatives in gamma(i+4)
9157       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9158       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9159       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9160 #ifdef MOMENT
9161       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9162       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9163       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9164 #endif
9165 c      s1d=0.0d0
9166 c      s2d=0.0d0
9167 c      s8d=0.0d0
9168 C      s12d=0.0d0
9169 c      s13d=0.0d0
9170 #ifdef MOMENT
9171       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9172 #else
9173       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9174 #endif
9175 C Derivatives in gamma(i+5)
9176 #ifdef MOMENT
9177       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9178       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9179       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9180 #endif
9181       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9182       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9183       s2d = scalar2(b1(1,itk),vtemp1d(1))
9184 #ifdef MOMENT
9185       call transpose2(AEA(1,1,2),atempd(1,1))
9186       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9187       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9188 #endif
9189       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9190       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9191 #ifdef MOMENT
9192       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9193       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9194       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9195 #endif
9196 c      s1d=0.0d0
9197 c      s2d=0.0d0
9198 c      s8d=0.0d0
9199 c      s12d=0.0d0
9200 c      s13d=0.0d0
9201 #ifdef MOMENT
9202       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9203      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9204 #else
9205       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9206      &               -0.5d0*ekont*(s2d+s12d)
9207 #endif
9208 C Cartesian derivatives
9209       do iii=1,2
9210         do kkk=1,5
9211           do lll=1,3
9212 #ifdef MOMENT
9213             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9214             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9215             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9216 #endif
9217             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9218             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9219      &          vtemp1d(1))
9220             s2d = scalar2(b1(1,itk),vtemp1d(1))
9221 #ifdef MOMENT
9222             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9223             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9224             s8d = -(atempd(1,1)+atempd(2,2))*
9225      &           scalar2(cc(1,1,itl),vtemp2(1))
9226 #endif
9227             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9228      &           auxmatd(1,1))
9229             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9230             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9231 c      s1d=0.0d0
9232 c      s2d=0.0d0
9233 c      s8d=0.0d0
9234 c      s12d=0.0d0
9235 c      s13d=0.0d0
9236 #ifdef MOMENT
9237             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9238      &        - 0.5d0*(s1d+s2d)
9239 #else
9240             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9241      &        - 0.5d0*s2d
9242 #endif
9243 #ifdef MOMENT
9244             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9245      &        - 0.5d0*(s8d+s12d)
9246 #else
9247             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9248      &        - 0.5d0*s12d
9249 #endif
9250           enddo
9251         enddo
9252       enddo
9253 #ifdef MOMENT
9254       do kkk=1,5
9255         do lll=1,3
9256           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9257      &      achuj_tempd(1,1))
9258           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9259           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9260           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9261           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9262           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9263      &      vtemp4d(1))
9264           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9265           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9266           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9267         enddo
9268       enddo
9269 #endif
9270 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9271 cd     &  16*eel_turn6_num
9272 cd      goto 1112
9273       if (j.lt.nres-1) then
9274         j1=j+1
9275         j2=j-1
9276       else
9277         j1=j-1
9278         j2=j-2
9279       endif
9280       if (l.lt.nres-1) then
9281         l1=l+1
9282         l2=l-1
9283       else
9284         l1=l-1
9285         l2=l-2
9286       endif
9287       do ll=1,3
9288 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9289 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9290 cgrad        ghalf=0.5d0*ggg1(ll)
9291 cd        ghalf=0.0d0
9292         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9293         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9294         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9295      &    +ekont*derx_turn(ll,2,1)
9296         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9297         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9298      &    +ekont*derx_turn(ll,4,1)
9299         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9300         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9301         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9302 cgrad        ghalf=0.5d0*ggg2(ll)
9303 cd        ghalf=0.0d0
9304         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9305      &    +ekont*derx_turn(ll,2,2)
9306         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9307         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9308      &    +ekont*derx_turn(ll,4,2)
9309         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9310         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9311         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9312       enddo
9313 cd      goto 1112
9314 cgrad      do m=i+1,j-1
9315 cgrad        do ll=1,3
9316 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9317 cgrad        enddo
9318 cgrad      enddo
9319 cgrad      do m=k+1,l-1
9320 cgrad        do ll=1,3
9321 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9322 cgrad        enddo
9323 cgrad      enddo
9324 cgrad1112  continue
9325 cgrad      do m=i+2,j2
9326 cgrad        do ll=1,3
9327 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9328 cgrad        enddo
9329 cgrad      enddo
9330 cgrad      do m=k+2,l2
9331 cgrad        do ll=1,3
9332 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9333 cgrad        enddo
9334 cgrad      enddo
9335 cd      do iii=1,nres-3
9336 cd        write (2,*) iii,g_corr6_loc(iii)
9337 cd      enddo
9338       eello_turn6=ekont*eel_turn6
9339 cd      write (2,*) 'ekont',ekont
9340 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9341       return
9342       end
9343
9344 C-----------------------------------------------------------------------------
9345       double precision function scalar(u,v)
9346 !DIR$ INLINEALWAYS scalar
9347 #ifndef OSF
9348 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9349 #endif
9350       implicit none
9351       double precision u(3),v(3)
9352 cd      double precision sc
9353 cd      integer i
9354 cd      sc=0.0d0
9355 cd      do i=1,3
9356 cd        sc=sc+u(i)*v(i)
9357 cd      enddo
9358 cd      scalar=sc
9359
9360       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9361       return
9362       end
9363 crc-------------------------------------------------
9364       SUBROUTINE MATVEC2(A1,V1,V2)
9365 !DIR$ INLINEALWAYS MATVEC2
9366 #ifndef OSF
9367 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9368 #endif
9369       implicit real*8 (a-h,o-z)
9370       include 'DIMENSIONS'
9371       DIMENSION A1(2,2),V1(2),V2(2)
9372 c      DO 1 I=1,2
9373 c        VI=0.0
9374 c        DO 3 K=1,2
9375 c    3     VI=VI+A1(I,K)*V1(K)
9376 c        Vaux(I)=VI
9377 c    1 CONTINUE
9378
9379       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9380       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9381
9382       v2(1)=vaux1
9383       v2(2)=vaux2
9384       END
9385 C---------------------------------------
9386       SUBROUTINE MATMAT2(A1,A2,A3)
9387 #ifndef OSF
9388 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9389 #endif
9390       implicit real*8 (a-h,o-z)
9391       include 'DIMENSIONS'
9392       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9393 c      DIMENSION AI3(2,2)
9394 c        DO  J=1,2
9395 c          A3IJ=0.0
9396 c          DO K=1,2
9397 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9398 c          enddo
9399 c          A3(I,J)=A3IJ
9400 c       enddo
9401 c      enddo
9402
9403       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9404       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9405       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9406       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9407
9408       A3(1,1)=AI3_11
9409       A3(2,1)=AI3_21
9410       A3(1,2)=AI3_12
9411       A3(2,2)=AI3_22
9412       END
9413
9414 c-------------------------------------------------------------------------
9415       double precision function scalar2(u,v)
9416 !DIR$ INLINEALWAYS scalar2
9417       implicit none
9418       double precision u(2),v(2)
9419       double precision sc
9420       integer i
9421       scalar2=u(1)*v(1)+u(2)*v(2)
9422       return
9423       end
9424
9425 C-----------------------------------------------------------------------------
9426
9427       subroutine transpose2(a,at)
9428 !DIR$ INLINEALWAYS transpose2
9429 #ifndef OSF
9430 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9431 #endif
9432       implicit none
9433       double precision a(2,2),at(2,2)
9434       at(1,1)=a(1,1)
9435       at(1,2)=a(2,1)
9436       at(2,1)=a(1,2)
9437       at(2,2)=a(2,2)
9438       return
9439       end
9440 c--------------------------------------------------------------------------
9441       subroutine transpose(n,a,at)
9442       implicit none
9443       integer n,i,j
9444       double precision a(n,n),at(n,n)
9445       do i=1,n
9446         do j=1,n
9447           at(j,i)=a(i,j)
9448         enddo
9449       enddo
9450       return
9451       end
9452 C---------------------------------------------------------------------------
9453       subroutine prodmat3(a1,a2,kk,transp,prod)
9454 !DIR$ INLINEALWAYS prodmat3
9455 #ifndef OSF
9456 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9457 #endif
9458       implicit none
9459       integer i,j
9460       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9461       logical transp
9462 crc      double precision auxmat(2,2),prod_(2,2)
9463
9464       if (transp) then
9465 crc        call transpose2(kk(1,1),auxmat(1,1))
9466 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9467 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9468
9469            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9470      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9471            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9472      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9473            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9474      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9475            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9476      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9477
9478       else
9479 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9480 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9481
9482            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9483      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9484            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9485      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9486            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9487      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9488            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9489      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9490
9491       endif
9492 c      call transpose2(a2(1,1),a2t(1,1))
9493
9494 crc      print *,transp
9495 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9496 crc      print *,((prod(i,j),i=1,2),j=1,2)
9497
9498       return
9499       end
9500