source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       call flush(iout)
  31       if (nfgtasks.gt.1) then
  32 #ifdef MPI
  33         time00=MPI_Wtime()
  34 #else
  35         time00=tcpu()
  36 #endif
  37 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  38         if (fg_rank.eq.0) then
  39           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  40 c          print *,"Processor",myrank," BROADCAST iorder"
  41 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  42 C FG slaves as WEIGHTS array.
  43           weights_(1)=wsc
  44           weights_(2)=wscp
  45           weights_(3)=welec
  46           weights_(4)=wcorr
  47           weights_(5)=wcorr5
  48           weights_(6)=wcorr6
  49           weights_(7)=wel_loc
  50           weights_(8)=wturn3
  51           weights_(9)=wturn4
  52           weights_(10)=wturn6
  53           weights_(11)=wang
  54           weights_(12)=wscloc
  55           weights_(13)=wtor
  56           weights_(14)=wtor_d
  57           weights_(15)=wstrain
  58           weights_(16)=wvdwpp
  59           weights_(17)=wbond
  60           weights_(18)=scal14
  61           weights_(21)=wsccor
  62           weights_(22)=wsct
  63 C FG Master broadcasts the WEIGHTS_ array
  64           call MPI_Bcast(weights_(1),n_ene,
  65      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  66         else
  67 C FG slaves receive the WEIGHTS array
  68           call MPI_Bcast(weights(1),n_ene,
  69      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  70           wsc=weights(1)
  71           wscp=weights(2)
  72           welec=weights(3)
  73           wcorr=weights(4)
  74           wcorr5=weights(5)
  75           wcorr6=weights(6)
  76           wel_loc=weights(7)
  77           wturn3=weights(8)
  78           wturn4=weights(9)
  79           wturn6=weights(10)
  80           wang=weights(11)
  81           wscloc=weights(12)
  82           wtor=weights(13)
  83           wtor_d=weights(14)
  84           wstrain=weights(15)
  85           wvdwpp=weights(16)
  86           wbond=weights(17)
  87           scal14=weights(18)
  88           wsccor=weights(21)
  89           wsct=weights(22)
  90         endif
  91         time_Bcast=time_Bcast+MPI_Wtime()-time00
  92         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  93 c        call chainbuild_cart
  94       endif
  95 c      write(iout,*) 'Processor',myrank,' calling etotal ipot=',ipot
  96 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  97 #else
  98 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  99 c        call int_from_cart1(.false.)
 100 c      endif
 101 #endif
 102 #ifdef TIMING
 103 #ifdef MPI
 104       time00=MPI_Wtime()
 105 #else
 106       time00=tcpu()
 107 #endif
 108 #endif
 109 C
 110 C Compute the side-chain and electrostatic interaction energy
 111 C
 112       goto (101,102,103,104,105,106) ipot
 113 C Lennard-Jones potential.
 114   101 call elj(evdw,evdw_p,evdw_m)
 115 cd    print '(a)','Exit ELJ'
 116       goto 107
 117 C Lennard-Jones-Kihara potential (shifted).
 118   102 call eljk(evdw,evdw_p,evdw_m)
 119       goto 107
 120 C Berne-Pechukas potential (dilated LJ, angular dependence).
 121   103 call ebp(evdw,evdw_p,evdw_m)
 122       goto 107
 123 C Gay-Berne potential (shifted LJ, angular dependence).
 124   104 call egb(evdw,evdw_p,evdw_m)
 125       goto 107
 126 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 127   105 call egbv(evdw,evdw_p,evdw_m)
 128       goto 107
 129 C Soft-sphere potential
 130   106 call e_softsphere(evdw)
 131 C
 132 C Calculate electrostatic (H-bonding) energy of the main chain.
 133 C
 134   107 continue
 135 C     BARTEK for dfa test!
 136       if (wdfa_dist.gt.0) then
 137         call edfad(edfadis)
 138       else
 139         edfadis=0
 140       endif
 141 c      print*, 'edfad is finished!', edfadis
 142       if (wdfa_tor.gt.0) then
 143         call edfat(edfator)
 144       else
 145         edfator=0
 146       endif
 147 c      print*, 'edfat is finished!', edfator
 148       if (wdfa_nei.gt.0) then
 149         call edfan(edfanei)
 150       else
 151         edfanei=0
 152       endif
 153 c      print*, 'edfan is finished!', edfanei
 154       if (wdfa_beta.gt.0) then
 155         call edfab(edfabet)
 156       else
 157         edfabet=0
 158       endif
 159 c      print*, 'edfab is finished!', edfabet
 160 cmc
 161 cmc Sep-06: egb takes care of dynamic ss bonds too
 162 cmc
 163 c      if (dyn_ss) call dyn_set_nss
 164
 165 c      print *,"Processor",myrank," computed USCSC"
 166 #ifdef TIMING
 167 #ifdef MPI
 168       time01=MPI_Wtime()
 169 #else
 170       time00=tcpu()
 171 #endif
 172 #endif
 173       call vec_and_deriv
 174 #ifdef TIMING
 175 #ifdef MPI
 176       time_vec=time_vec+MPI_Wtime()-time01
 177 #else
 178       time_vec=time_vec+tcpu()-time01
 179 #endif
 180 #endif
 181 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 182       if (ipot.lt.6) then
 183 #ifdef SPLITELE
 184          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 185      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 186      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 187      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 188 #else
 189          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 190      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 191      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 192      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 193 #endif
 194             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 195          else
 196             ees=0.0d0
 197             evdw1=0.0d0
 198             eel_loc=0.0d0
 199             eello_turn3=0.0d0
 200             eello_turn4=0.0d0
 201          endif
 202       else
 203 c        write (iout,*) "Soft-spheer ELEC potential"
 204         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 205      &   eello_turn4)
 206       endif
 207 c      print *,"Processor",myrank," computed UELEC"
 208 C
 209 C Calculate excluded-volume interaction energy between peptide groups
 210 C and side chains.
 211 C
 212       if (ipot.lt.6) then
 213        if(wscp.gt.0d0) then
 214         call escp(evdw2,evdw2_14)
 215        else
 216         evdw2=0
 217         evdw2_14=0
 218        endif
 219       else
 220 c        write (iout,*) "Soft-sphere SCP potential"
 221         call escp_soft_sphere(evdw2,evdw2_14)
 222       endif
 223 c
 224 c Calculate the bond-stretching energy
 225 c
 226       call ebond(estr)
 227 C
 228 C Calculate the disulfide-bridge and other energy and the contributions
 229 C from other distance constraints.
 230 cd    print *,'Calling EHPB'
 231       call edis(ehpb)
 232 cd    print *,'EHPB exitted succesfully.'
 233 C
 234 C Calculate the virtual-bond-angle energy.
 235 C
 236       if (wang.gt.0d0) then
 237         call ebend(ebe)
 238       else
 239         ebe=0
 240       endif
 241 c      print *,"Processor",myrank," computed UB"
 242 C
 243 C Calculate the SC local energy.
 244 C
 245       call esc(escloc)
 246 c      print *,"Processor",myrank," computed USC"
 247 C
 248 C Calculate the virtual-bond torsional energy.
 249 C
 250 cd    print *,'nterm=',nterm
 251       if (wtor.gt.0) then
 252        call etor(etors,edihcnstr)
 253       else
 254        etors=0
 255        edihcnstr=0
 256       endif
 257
 258       if (constr_homology.ge.1) then
 259         call e_modeller(ehomology_constr)
 260       else
 261         ehomology_constr=0.0d0
 262       endif
 263
 264
 265 c      write(iout,*) ehomology_constr
 266 c      print *,"Processor",myrank," computed Utor"
 267 C
 268 C 6/23/01 Calculate double-torsional energy
 269 C
 270       if (wtor_d.gt.0) then
 271        call etor_d(etors_d)
 272       else
 273        etors_d=0
 274       endif
 275 c      print *,"Processor",myrank," computed Utord"
 276 C
 277 C 21/5/07 Calculate local sicdechain correlation energy
 278 C
 279       if (wsccor.gt.0.0d0) then
 280         call eback_sc_corr(esccor)
 281       else
 282         esccor=0.0d0
 283       endif
 284 c      print *,"Processor",myrank," computed Usccorr"
 285 C
 286 C 12/1/95 Multi-body terms
 287 C
 288       n_corr=0
 289       n_corr1=0
 290       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 291      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 292          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 293 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 294 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 295       else
 296          ecorr=0.0d0
 297          ecorr5=0.0d0
 298          ecorr6=0.0d0
 299          eturn6=0.0d0
 300       endif
 301       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 302          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 303 cd         write (iout,*) "multibody_hb ecorr",ecorr
 304       endif
 305 c      print *,"Processor",myrank," computed Ucorr"
 306 C
 307 C If performing constraint dynamics, call the constraint energy
 308 C  after the equilibration time
 309       if(usampl.and.totT.gt.eq_time) then
 310 c         write (iout,*) "CALL TO ECONSTR_BACK"
 311          call EconstrQ
 312          call Econstr_back
 313       else
 314          Uconst=0.0d0
 315          Uconst_back=0.0d0
 316       endif
 317 #ifdef TIMING
 318 #ifdef MPI
 319       time_enecalc=time_enecalc+MPI_Wtime()-time00
 320 #else
 321       time_enecalc=time_enecalc+tcpu()-time00
 322 #endif
 323 #endif
 324 c      print *,"Processor",myrank," computed Uconstr"
 325 #ifdef TIMING
 326 #ifdef MPI
 327       time00=MPI_Wtime()
 328 #else
 329       time00=tcpu()
 330 #endif
 331 #endif
 332 c
 333 C Sum the energies
 334 C
 335       energia(1)=evdw
 336 #ifdef SCP14
 337       energia(2)=evdw2-evdw2_14
 338       energia(18)=evdw2_14
 339 #else
 340       energia(2)=evdw2
 341       energia(18)=0.0d0
 342 #endif
 343 #ifdef SPLITELE
 344       energia(3)=ees
 345       energia(16)=evdw1
 346 #else
 347       energia(3)=ees+evdw1
 348       energia(16)=0.0d0
 349 #endif
 350       energia(4)=ecorr
 351       energia(5)=ecorr5
 352       energia(6)=ecorr6
 353       energia(7)=eel_loc
 354       energia(8)=eello_turn3
 355       energia(9)=eello_turn4
 356       energia(10)=eturn6
 357       energia(11)=ebe
 358       energia(12)=escloc
 359       energia(13)=etors
 360       energia(14)=etors_d
 361       energia(15)=ehpb
 362       energia(19)=edihcnstr
 363       energia(17)=estr
 364       energia(20)=Uconst+Uconst_back
 365       energia(21)=esccor
 366       energia(22)=evdw_p
 367       energia(23)=evdw_m
 368       energia(24)=ehomology_constr
 369       energia(25)=edfadis
 370       energia(26)=edfator
 371       energia(27)=edfanei
 372       energia(28)=edfabet
 373 c      print *," Processor",myrank," calls SUM_ENERGY"
 374       call sum_energy(energia,.true.)
 375       if (dyn_ss) call dyn_set_nss
 376 c      print *," Processor",myrank," left SUM_ENERGY"
 377 #ifdef TIMING
 378 #ifdef MPI
 379       time_sumene=time_sumene+MPI_Wtime()-time00
 380 #else
 381       time_sumene=time_sumene+tcpu()-time00
 382 #endif
 383 #endif
 384       return
 385       end
 386 c-------------------------------------------------------------------------------
 387       subroutine sum_energy(energia,reduce)
 388       implicit real*8 (a-h,o-z)
 389       include 'DIMENSIONS'
 390 #ifndef ISNAN
 391       external proc_proc
 392 #ifdef WINPGI
 393 cMS$ATTRIBUTES C ::  proc_proc
 394 #endif
 395 #endif
 396 #ifdef MPI
 397       include "mpif.h"
 398 #endif
 399       include 'COMMON.SETUP'
 400       include 'COMMON.IOUNITS'
 401       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 402       include 'COMMON.FFIELD'
 403       include 'COMMON.DERIV'
 404       include 'COMMON.INTERACT'
 405       include 'COMMON.SBRIDGE'
 406       include 'COMMON.CHAIN'
 407       include 'COMMON.VAR'
 408       include 'COMMON.CONTROL'
 409       include 'COMMON.TIME1'
 410       logical reduce
 411 #ifdef MPI
 412       if (nfgtasks.gt.1 .and. reduce) then
 413 #ifdef DEBUG
 414         write (iout,*) "energies before REDUCE"
 415         call enerprint(energia)
 416         call flush(iout)
 417 #endif
 418         do i=0,n_ene
 419           enebuff(i)=energia(i)
 420         enddo
 421         time00=MPI_Wtime()
 422         call MPI_Barrier(FG_COMM,IERR)
 423         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 424         time00=MPI_Wtime()
 425         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 426      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 427 #ifdef DEBUG
 428         write (iout,*) "energies after REDUCE"
 429         call enerprint(energia)
 430         call flush(iout)
 431 #endif
 432         time_Reduce=time_Reduce+MPI_Wtime()-time00
 433       endif
 434       if (fg_rank.eq.0) then
 435 #endif
 436 #ifdef TSCSC
 437       evdw=energia(22)+wsct*energia(23)
 438 #else
 439       evdw=energia(1)
 440 #endif
 441 #ifdef SCP14
 442       evdw2=energia(2)+energia(18)
 443       evdw2_14=energia(18)
 444 #else
 445       evdw2=energia(2)
 446 #endif
 447 #ifdef SPLITELE
 448       ees=energia(3)
 449       evdw1=energia(16)
 450 #else
 451       ees=energia(3)
 452       evdw1=0.0d0
 453 #endif
 454       ecorr=energia(4)
 455       ecorr5=energia(5)
 456       ecorr6=energia(6)
 457       eel_loc=energia(7)
 458       eello_turn3=energia(8)
 459       eello_turn4=energia(9)
 460       eturn6=energia(10)
 461       ebe=energia(11)
 462       escloc=energia(12)
 463       etors=energia(13)
 464       etors_d=energia(14)
 465       ehpb=energia(15)
 466       edihcnstr=energia(19)
 467       estr=energia(17)
 468       Uconst=energia(20)
 469       esccor=energia(21)
 470       ehomology_constr=energia(24)
 471       edfadis=energia(25)
 472       edfator=energia(26)
 473       edfanei=energia(27)
 474       edfabet=energia(28)
 475 #ifdef SPLITELE
 476       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 477      & +wang*ebe+wtor*etors+wscloc*escloc
 478      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 479      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 480      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 481      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 482      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 483      & +wdfa_beta*edfabet
 484 #else
 485       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 486      & +wang*ebe+wtor*etors+wscloc*escloc
 487      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 488      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 489      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 490      & +wbond*estr+Uconst+wsccor*esccor+ehomology_constr
 491      & +wdfa_dist*edfadis+wdfa_tor*edfator+wdfa_nei*edfanei
 492      & +wdfa_beta*edfabet
 493 #endif
 494       energia(0)=etot
 495 c detecting NaNQ
 496 #ifdef ISNAN
 497 #ifdef AIX
 498       if (isnan(etot).ne.0) energia(0)=1.0d+99
 499 #else
 500       if (isnan(etot)) energia(0)=1.0d+99
 501 #endif
 502 #else
 503       i=0
 504 #ifdef WINPGI
 505       idumm=proc_proc(etot,i)
 506 #else
 507       call proc_proc(etot,i)
 508 #endif
 509       if(i.eq.1)energia(0)=1.0d+99
 510 #endif
 511 #ifdef MPI
 512       endif
 513 #endif
 514       return
 515       end
 516 c-------------------------------------------------------------------------------
 517       subroutine sum_gradient
 518       implicit real*8 (a-h,o-z)
 519       include 'DIMENSIONS'
 520 #ifndef ISNAN
 521       external proc_proc
 522 #ifdef WINPGI
 523 cMS$ATTRIBUTES C ::  proc_proc
 524 #endif
 525 #endif
 526 #ifdef MPI
 527       include 'mpif.h'
 528 #endif
 529       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 530      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 531       include 'COMMON.SETUP'
 532       include 'COMMON.IOUNITS'
 533       include 'COMMON.FFIELD'
 534       include 'COMMON.DERIV'
 535       include 'COMMON.INTERACT'
 536       include 'COMMON.SBRIDGE'
 537       include 'COMMON.CHAIN'
 538       include 'COMMON.VAR'
 539       include 'COMMON.CONTROL'
 540       include 'COMMON.TIME1'
 541       include 'COMMON.MAXGRAD'
 542       include 'COMMON.SCCOR'
 543 #ifdef TIMING
 544 #ifdef MPI
 545       time01=MPI_Wtime()
 546 #else
 547       time01=tcpu()
 548 #endif
 549 #endif
 550 #ifdef DEBUG
 551       write (iout,*) "sum_gradient gvdwc, gvdwx"
 552       do i=1,nres
 553         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 554      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 555      &   (gvdwcT(j,i),j=1,3)
 556       enddo
 557       call flush(iout)
 558 #endif
 559 #ifdef MPI
 560 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 561         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 562      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 563 #endif
 564 C
 565 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 566 C            in virtual-bond-vector coordinates
 567 C
 568 #ifdef DEBUG
 569 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 570 c      do i=1,nres-1
 571 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 572 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 573 c      enddo
 574 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 575 c      do i=1,nres-1
 576 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 577 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 578 c      enddo
 579       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 580       do i=1,nres
 581         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 582      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 583      &   g_corr5_loc(i)
 584       enddo
 585       call flush(iout)
 586 #endif
 587 #ifdef SPLITELE
 588 #ifdef TSCSC
 589       do i=1,nct
 590         do j=1,3
 591           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 592      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 593      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 594      &                wel_loc*gel_loc_long(j,i)+
 595      &                wcorr*gradcorr_long(j,i)+
 596      &                wcorr5*gradcorr5_long(j,i)+
 597      &                wcorr6*gradcorr6_long(j,i)+
 598      &                wturn6*gcorr6_turn_long(j,i)+
 599      &                wstrain*ghpbc(j,i)+
 600      &                wdfa_dist*gdfad(j,i)+
 601      &                wdfa_tor*gdfat(j,i)+
 602      &                wdfa_nei*gdfan(j,i)+
 603      &                wdfa_beta*gdfab(j,i)
 604         enddo
 605       enddo
 606 #else
 607       do i=1,nct
 608         do j=1,3
 609           gradbufc(j,i)=wsc*gvdwc(j,i)+
 610      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 611      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 612      &                wel_loc*gel_loc_long(j,i)+
 613      &                wcorr*gradcorr_long(j,i)+
 614      &                wcorr5*gradcorr5_long(j,i)+
 615      &                wcorr6*gradcorr6_long(j,i)+
 616      &                wturn6*gcorr6_turn_long(j,i)+
 617      &                wstrain*ghpbc(j,i)+
 618      &                wdfa_dist*gdfad(j,i)+
 619      &                wdfa_tor*gdfat(j,i)+
 620      &                wdfa_nei*gdfan(j,i)+
 621      &                wdfa_beta*gdfab(j,i)
 622         enddo
 623       enddo
 624 #endif
 625 #else
 626       do i=1,nct
 627         do j=1,3
 628           gradbufc(j,i)=wsc*gvdwc(j,i)+
 629      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 630      &                welec*gelc_long(j,i)+
 631      &                wbond*gradb(j,i)+
 632      &                wel_loc*gel_loc_long(j,i)+
 633      &                wcorr*gradcorr_long(j,i)+
 634      &                wcorr5*gradcorr5_long(j,i)+
 635      &                wcorr6*gradcorr6_long(j,i)+
 636      &                wturn6*gcorr6_turn_long(j,i)+
 637      &                wstrain*ghpbc(j,i)+
 638      &                wdfa_dist*gdfad(j,i)+
 639      &                wdfa_tor*gdfat(j,i)+
 640      &                wdfa_nei*gdfan(j,i)+
 641      &                wdfa_beta*gdfab(j,i)
 642         enddo
 643       enddo
 644 #endif
 645 #ifdef MPI
 646       if (nfgtasks.gt.1) then
 647       time00=MPI_Wtime()
 648 #ifdef DEBUG
 649       write (iout,*) "gradbufc before allreduce"
 650       do i=1,nres
 651         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 652       enddo
 653       call flush(iout)
 654 #endif
 655       do i=1,nres
 656         do j=1,3
 657           gradbufc_sum(j,i)=gradbufc(j,i)
 658         enddo
 659       enddo
 660 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 661 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 662 c      time_reduce=time_reduce+MPI_Wtime()-time00
 663 #ifdef DEBUG
 664 c      write (iout,*) "gradbufc_sum after allreduce"
 665 c      do i=1,nres
 666 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 667 c      enddo
 668 c      call flush(iout)
 669 #endif
 670 #ifdef TIMING
 671 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 672 #endif
 673       do i=nnt,nres
 674         do k=1,3
 675           gradbufc(k,i)=0.0d0
 676         enddo
 677       enddo
 678 #ifdef DEBUG
 679       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 680       write (iout,*) (i," jgrad_start",jgrad_start(i),
 681      &                  " jgrad_end  ",jgrad_end(i),
 682      &                  i=igrad_start,igrad_end)
 683 #endif
 684 c
 685 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 686 c do not parallelize this part.
 687 c
 688 c      do i=igrad_start,igrad_end
 689 c        do j=jgrad_start(i),jgrad_end(i)
 690 c          do k=1,3
 691 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 692 c          enddo
 693 c        enddo
 694 c      enddo
 695       do j=1,3
 696         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 697       enddo
 698       do i=nres-2,nnt,-1
 699         do j=1,3
 700           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 701         enddo
 702       enddo
 703 #ifdef DEBUG
 704       write (iout,*) "gradbufc after summing"
 705       do i=1,nres
 706         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 707       enddo
 708       call flush(iout)
 709 #endif
 710       else
 711 #endif
 712 #ifdef DEBUG
 713       write (iout,*) "gradbufc"
 714       do i=1,nres
 715         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 716       enddo
 717       call flush(iout)
 718 #endif
 719       do i=1,nres
 720         do j=1,3
 721           gradbufc_sum(j,i)=gradbufc(j,i)
 722           gradbufc(j,i)=0.0d0
 723         enddo
 724       enddo
 725       do j=1,3
 726         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 727       enddo
 728       do i=nres-2,nnt,-1
 729         do j=1,3
 730           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 731         enddo
 732       enddo
 733 c      do i=nnt,nres-1
 734 c        do k=1,3
 735 c          gradbufc(k,i)=0.0d0
 736 c        enddo
 737 c        do j=i+1,nres
 738 c          do k=1,3
 739 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 740 c          enddo
 741 c        enddo
 742 c      enddo
 743 #ifdef DEBUG
 744       write (iout,*) "gradbufc after summing"
 745       do i=1,nres
 746         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 747       enddo
 748       call flush(iout)
 749 #endif
 750 #ifdef MPI
 751       endif
 752 #endif
 753       do k=1,3
 754         gradbufc(k,nres)=0.0d0
 755       enddo
 756       do i=1,nct
 757         do j=1,3
 758 #ifdef SPLITELE
 759           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 760      &                wel_loc*gel_loc(j,i)+
 761      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 762      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 763      &                wel_loc*gel_loc_long(j,i)+
 764      &                wcorr*gradcorr_long(j,i)+
 765      &                wcorr5*gradcorr5_long(j,i)+
 766      &                wcorr6*gradcorr6_long(j,i)+
 767      &                wturn6*gcorr6_turn_long(j,i))+
 768      &                wbond*gradb(j,i)+
 769      &                wcorr*gradcorr(j,i)+
 770      &                wturn3*gcorr3_turn(j,i)+
 771      &                wturn4*gcorr4_turn(j,i)+
 772      &                wcorr5*gradcorr5(j,i)+
 773      &                wcorr6*gradcorr6(j,i)+
 774      &                wturn6*gcorr6_turn(j,i)+
 775      &                wsccor*gsccorc(j,i)
 776      &               +wscloc*gscloc(j,i)
 777 #else
 778           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 779      &                wel_loc*gel_loc(j,i)+
 780      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 781      &                welec*gelc_long(j,i)+
 782      &                wel_loc*gel_loc_long(j,i)+
 783      &                wcorr*gcorr_long(j,i)+
 784      &                wcorr5*gradcorr5_long(j,i)+
 785      &                wcorr6*gradcorr6_long(j,i)+
 786      &                wturn6*gcorr6_turn_long(j,i))+
 787      &                wbond*gradb(j,i)+
 788      &                wcorr*gradcorr(j,i)+
 789      &                wturn3*gcorr3_turn(j,i)+
 790      &                wturn4*gcorr4_turn(j,i)+
 791      &                wcorr5*gradcorr5(j,i)+
 792      &                wcorr6*gradcorr6(j,i)+
 793      &                wturn6*gcorr6_turn(j,i)+
 794      &                wsccor*gsccorc(j,i)
 795      &               +wscloc*gscloc(j,i)
 796 #endif
 797 #ifdef TSCSC
 798           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 799      &                  wscp*gradx_scp(j,i)+
 800      &                  wbond*gradbx(j,i)+
 801      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 802      &                  wsccor*gsccorx(j,i)
 803      &                 +wscloc*gsclocx(j,i)
 804 #else
 805           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 806      &                  wbond*gradbx(j,i)+
 807      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 808      &                  wsccor*gsccorx(j,i)
 809      &                 +wscloc*gsclocx(j,i)
 810 #endif
 811         enddo
 812       enddo
 813 #ifdef DEBUG
 814       write (iout,*) "gloc before adding corr"
 815       do i=1,4*nres
 816         write (iout,*) i,gloc(i,icg)
 817       enddo
 818 #endif
 819       do i=1,nres-3
 820         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 821      &   +wcorr5*g_corr5_loc(i)
 822      &   +wcorr6*g_corr6_loc(i)
 823      &   +wturn4*gel_loc_turn4(i)
 824      &   +wturn3*gel_loc_turn3(i)
 825      &   +wturn6*gel_loc_turn6(i)
 826      &   +wel_loc*gel_loc_loc(i)
 827       enddo
 828 #ifdef DEBUG
 829       write (iout,*) "gloc after adding corr"
 830       do i=1,4*nres
 831         write (iout,*) i,gloc(i,icg)
 832       enddo
 833 #endif
 834 #ifdef MPI
 835       if (nfgtasks.gt.1) then
 836         do j=1,3
 837           do i=1,nres
 838             gradbufc(j,i)=gradc(j,i,icg)
 839             gradbufx(j,i)=gradx(j,i,icg)
 840           enddo
 841         enddo
 842         do i=1,4*nres
 843           glocbuf(i)=gloc(i,icg)
 844         enddo
 845 #ifdef DEBUG
 846       write (iout,*) "gloc_sc before reduce"
 847       do i=1,nres
 848        do j=1,3
 849         write (iout,*) i,j,gloc_sc(j,i,icg)
 850        enddo
 851       enddo
 852 #endif
 853         do i=1,nres
 854          do j=1,3
 855           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 856          enddo
 857         enddo
 858         time00=MPI_Wtime()
 859         call MPI_Barrier(FG_COMM,IERR)
 860         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 861         time00=MPI_Wtime()
 862         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 863      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 864         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 865      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 866         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 867      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 868         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 869      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 870         time_reduce=time_reduce+MPI_Wtime()-time00
 871 #ifdef DEBUG
 872       write (iout,*) "gloc_sc after reduce"
 873       do i=1,nres
 874        do j=1,3
 875         write (iout,*) i,j,gloc_sc(j,i,icg)
 876        enddo
 877       enddo
 878 #endif
 879 #ifdef DEBUG
 880       write (iout,*) "gloc after reduce"
 881       do i=1,4*nres
 882         write (iout,*) i,gloc(i,icg)
 883       enddo
 884 #endif
 885       endif
 886 #endif
 887       if (gnorm_check) then
 888 c
 889 c Compute the maximum elements of the gradient
 890 c
 891       gvdwc_max=0.0d0
 892       gvdwc_scp_max=0.0d0
 893       gelc_max=0.0d0
 894       gvdwpp_max=0.0d0
 895       gradb_max=0.0d0
 896       ghpbc_max=0.0d0
 897       gradcorr_max=0.0d0
 898       gel_loc_max=0.0d0
 899       gcorr3_turn_max=0.0d0
 900       gcorr4_turn_max=0.0d0
 901       gradcorr5_max=0.0d0
 902       gradcorr6_max=0.0d0
 903       gcorr6_turn_max=0.0d0
 904       gsccorc_max=0.0d0
 905       gscloc_max=0.0d0
 906       gvdwx_max=0.0d0
 907       gradx_scp_max=0.0d0
 908       ghpbx_max=0.0d0
 909       gradxorr_max=0.0d0
 910       gsccorx_max=0.0d0
 911       gsclocx_max=0.0d0
 912       do i=1,nct
 913         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 914         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 915 #ifdef TSCSC
 916         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 917         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 918 #endif
 919         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 920         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 921      &   gvdwc_scp_max=gvdwc_scp_norm
 922         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 923         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 924         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 925         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 926         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 927         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 928         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 929         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 930         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 931         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 932         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 933         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 934         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 935      &    gcorr3_turn(1,i)))
 936         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 937      &    gcorr3_turn_max=gcorr3_turn_norm
 938         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 939      &    gcorr4_turn(1,i)))
 940         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 941      &    gcorr4_turn_max=gcorr4_turn_norm
 942         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 943         if (gradcorr5_norm.gt.gradcorr5_max)
 944      &    gradcorr5_max=gradcorr5_norm
 945         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 946         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 947         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 948      &    gcorr6_turn(1,i)))
 949         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 950      &    gcorr6_turn_max=gcorr6_turn_norm
 951         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 952         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 953         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 954         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 955         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 956         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 957 #ifdef TSCSC
 958         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 959         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 960 #endif
 961         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 962         if (gradx_scp_norm.gt.gradx_scp_max)
 963      &    gradx_scp_max=gradx_scp_norm
 964         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 965         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 966         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 967         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 968         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 969         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 970         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 971         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 972       enddo
 973       if (gradout) then
 974 #ifdef AIX
 975         open(istat,file=statname,position="append")
 976 #else
 977         open(istat,file=statname,access="append")
 978 #endif
 979         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 980      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 981      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 982      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 983      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 984      &     gsccorx_max,gsclocx_max
 985         close(istat)
 986         if (gvdwc_max.gt.1.0d4) then
 987           write (iout,*) "gvdwc gvdwx gradb gradbx"
 988           do i=nnt,nct
 989             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 990      &        gradb(j,i),gradbx(j,i),j=1,3)
 991           enddo
 992           call pdbout(0.0d0,'cipiszcze',iout)
 993           call flush(iout)
 994         endif
 995       endif
 996       endif
 997 #ifdef DEBUG
 998       write (iout,*) "gradc gradx gloc"
 999       do i=1,nres
1000         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1001      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1002       enddo
1003 #endif
1004 #ifdef TIMING
1005 #ifdef MPI
1006       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1007 #else
1008       time_sumgradient=time_sumgradient+tcpu()-time01
1009 #endif
1010 #endif
1011       return
1012       end
1013 c-------------------------------------------------------------------------------
1014       subroutine rescale_weights(t_bath)
1015       implicit real*8 (a-h,o-z)
1016       include 'DIMENSIONS'
1017       include 'COMMON.IOUNITS'
1018       include 'COMMON.FFIELD'
1019       include 'COMMON.SBRIDGE'
1020       double precision kfac /2.4d0/
1021       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1022 c      facT=temp0/t_bath
1023 c      facT=2*temp0/(t_bath+temp0)
1024       if (rescale_mode.eq.0) then
1025         facT=1.0d0
1026         facT2=1.0d0
1027         facT3=1.0d0
1028         facT4=1.0d0
1029         facT5=1.0d0
1030       else if (rescale_mode.eq.1) then
1031         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1032         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1033         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1034         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1035         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1036       else if (rescale_mode.eq.2) then
1037         x=t_bath/temp0
1038         x2=x*x
1039         x3=x2*x
1040         x4=x3*x
1041         x5=x4*x
1042         facT=licznik/dlog(dexp(x)+dexp(-x))
1043         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1044         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1045         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1046         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1047       else
1048         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1049         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1050 #ifdef MPI
1051        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1052 #endif
1053        stop 555
1054       endif
1055       welec=weights(3)*fact
1056       wcorr=weights(4)*fact3
1057       wcorr5=weights(5)*fact4
1058       wcorr6=weights(6)*fact5
1059       wel_loc=weights(7)*fact2
1060       wturn3=weights(8)*fact2
1061       wturn4=weights(9)*fact3
1062       wturn6=weights(10)*fact5
1063       wtor=weights(13)*fact
1064       wtor_d=weights(14)*fact2
1065       wsccor=weights(21)*fact
1066 #ifdef TSCSC
1067 c      wsct=t_bath/temp0
1068       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1069 #endif
1070       return
1071       end
1072 C------------------------------------------------------------------------
1073       subroutine enerprint(energia)
1074       implicit real*8 (a-h,o-z)
1075       include 'DIMENSIONS'
1076       include 'COMMON.IOUNITS'
1077       include 'COMMON.FFIELD'
1078       include 'COMMON.SBRIDGE'
1079       include 'COMMON.MD'
1080       double precision energia(0:n_ene)
1081       etot=energia(0)
1082 #ifdef TSCSC
1083       evdw=energia(22)+wsct*energia(23)
1084 #else
1085       evdw=energia(1)
1086 #endif
1087       evdw2=energia(2)
1088 #ifdef SCP14
1089       evdw2=energia(2)+energia(18)
1090 #else
1091       evdw2=energia(2)
1092 #endif
1093       ees=energia(3)
1094 #ifdef SPLITELE
1095       evdw1=energia(16)
1096 #endif
1097       ecorr=energia(4)
1098       ecorr5=energia(5)
1099       ecorr6=energia(6)
1100       eel_loc=energia(7)
1101       eello_turn3=energia(8)
1102       eello_turn4=energia(9)
1103       eello_turn6=energia(10)
1104       ebe=energia(11)
1105       escloc=energia(12)
1106       etors=energia(13)
1107       etors_d=energia(14)
1108       ehpb=energia(15)
1109       edihcnstr=energia(19)
1110       estr=energia(17)
1111       Uconst=energia(20)
1112       esccor=energia(21)
1113       ehomology_constr=energia(24)
1114 C     Bartek
1115       edfadis = energia(25)
1116       edfator = energia(26)
1117       edfanei = energia(27)
1118       edfabet = energia(28)
1119
1120 #ifdef SPLITELE
1121       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1122      &  estr,wbond,ebe,wang,
1123      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1124      &  ecorr,wcorr,
1125      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1126      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1127      &  edihcnstr,ehomology_constr, ebr*nss,
1128      &  Uconst,edfadis,wdfa_dist,edfator,wdfa_tor,edfanei,wdfa_nei,
1129      &  edfabet,wdfa_beta,etot
1130    10 format (/'Virtual-chain energies:'//
1131      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1132      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1133      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1134      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1135      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1136      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1137      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1138      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1139      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1140      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1141      & ' (SS bridges & dist. cnstr.)'/
1142      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1143      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1144      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1145      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1146      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1147      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1148      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1149      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1150      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1151      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1152      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1153      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1154      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA distance energy)'/
1155      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA torsion energy)'/
1156      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA NCa energy)'/
1157      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pE16.6,' (DFA Beta energy)'/
1158      & 'ETOT=  ',1pE16.6,' (total)')
1159 #else
1160       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1161      &  estr,wbond,ebe,wang,
1162      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1163      &  ecorr,wcorr,
1164      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1165      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1166      &  ehomology_constr,ebr*nss,Uconst,edfadis,wdfa_dist,edfator,
1167      &  wdfa_tor,edfanei,wdfa_nei,edfabet,wdfa_beta,
1168      &  etot
1169    10 format (/'Virtual-chain energies:'//
1170      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1171      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1172      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1173      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1174      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1175      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1176      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1177      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1178      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1179      & ' (SS bridges & dist. cnstr.)'/
1180      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1181      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1182      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1183      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1184      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1185      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1186      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1187      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1188      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1189      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
1190      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1191      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1192      & 'EDFAD= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA distance energy)'/
1193      & 'EDFAT= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA torsion energy)'/
1194      & 'EDFAN= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA NCa energy)'/
1195      & 'EDFAB= ',1pE16.6,' WEIGHT=',1pD16.6,' (DFA Beta energy)'/
1196      & 'ETOT=  ',1pE16.6,' (total)')
1197 #endif
1198       return
1199       end
1200 C-----------------------------------------------------------------------
1201       subroutine elj(evdw,evdw_p,evdw_m)
1202 C
1203 C This subroutine calculates the interaction energy of nonbonded side chains
1204 C assuming the LJ potential of interaction.
1205 C
1206       implicit real*8 (a-h,o-z)
1207       include 'DIMENSIONS'
1208       parameter (accur=1.0d-10)
1209       include 'COMMON.GEO'
1210       include 'COMMON.VAR'
1211       include 'COMMON.LOCAL'
1212       include 'COMMON.CHAIN'
1213       include 'COMMON.DERIV'
1214       include 'COMMON.INTERACT'
1215       include 'COMMON.TORSION'
1216       include 'COMMON.SBRIDGE'
1217       include 'COMMON.NAMES'
1218       include 'COMMON.IOUNITS'
1219       include 'COMMON.CONTACTS'
1220       dimension gg(3)
1221 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1222       evdw=0.0D0
1223       do i=iatsc_s,iatsc_e
1224         itypi=itype(i)
1225         itypi1=itype(i+1)
1226         xi=c(1,nres+i)
1227         yi=c(2,nres+i)
1228         zi=c(3,nres+i)
1229 C Change 12/1/95
1230         num_conti=0
1231 C
1232 C Calculate SC interaction energy.
1233 C
1234         do iint=1,nint_gr(i)
1235 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1236 cd   &                  'iend=',iend(i,iint)
1237           do j=istart(i,iint),iend(i,iint)
1238             itypj=itype(j)
1239             xj=c(1,nres+j)-xi
1240             yj=c(2,nres+j)-yi
1241             zj=c(3,nres+j)-zi
1242 C Change 12/1/95 to calculate four-body interactions
1243             rij=xj*xj+yj*yj+zj*zj
1244             rrij=1.0D0/rij
1245 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1246             eps0ij=eps(itypi,itypj)
1247             fac=rrij**expon2
1248             e1=fac*fac*aa(itypi,itypj)
1249             e2=fac*bb(itypi,itypj)
1250             evdwij=e1+e2
1251 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1252 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1253 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1254 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1255 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1256 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1257 #ifdef TSCSC
1258             if (bb(itypi,itypj).gt.0) then
1259                evdw_p=evdw_p+evdwij
1260             else
1261                evdw_m=evdw_m+evdwij
1262             endif
1263 #else
1264             evdw=evdw+evdwij
1265 #endif
1266 C
1267 C Calculate the components of the gradient in DC and X
1268 C
1269             fac=-rrij*(e1+evdwij)
1270             gg(1)=xj*fac
1271             gg(2)=yj*fac
1272             gg(3)=zj*fac
1273 #ifdef TSCSC
1274             if (bb(itypi,itypj).gt.0.0d0) then
1275               do k=1,3
1276                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1277                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1278                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1279                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1280               enddo
1281             else
1282               do k=1,3
1283                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1284                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1285                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1286                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1287               enddo
1288             endif
1289 #else
1290             do k=1,3
1291               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1292               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1293               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1294               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1295             enddo
1296 #endif
1297 cgrad            do k=i,j-1
1298 cgrad              do l=1,3
1299 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1300 cgrad              enddo
1301 cgrad            enddo
1302 C
1303 C 12/1/95, revised on 5/20/97
1304 C
1305 C Calculate the contact function. The ith column of the array JCONT will
1306 C contain the numbers of atoms that make contacts with the atom I (of numbers
1307 C greater than I). The arrays FACONT and GACONT will contain the values of
1308 C the contact function and its derivative.
1309 C
1310 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1311 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1312 C Uncomment next line, if the correlation interactions are contact function only
1313             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1314               rij=dsqrt(rij)
1315               sigij=sigma(itypi,itypj)
1316               r0ij=rs0(itypi,itypj)
1317 C
1318 C Check whether the SC's are not too far to make a contact.
1319 C
1320               rcut=1.5d0*r0ij
1321               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1322 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1323 C
1324               if (fcont.gt.0.0D0) then
1325 C If the SC-SC distance if close to sigma, apply spline.
1326 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1327 cAdam &             fcont1,fprimcont1)
1328 cAdam           fcont1=1.0d0-fcont1
1329 cAdam           if (fcont1.gt.0.0d0) then
1330 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1331 cAdam             fcont=fcont*fcont1
1332 cAdam           endif
1333 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1334 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1335 cga             do k=1,3
1336 cga               gg(k)=gg(k)*eps0ij
1337 cga             enddo
1338 cga             eps0ij=-evdwij*eps0ij
1339 C Uncomment for AL's type of SC correlation interactions.
1340 cadam           eps0ij=-evdwij
1341                 num_conti=num_conti+1
1342                 jcont(num_conti,i)=j
1343                 facont(num_conti,i)=fcont*eps0ij
1344                 fprimcont=eps0ij*fprimcont/rij
1345                 fcont=expon*fcont
1346 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1347 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1348 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1349 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1350                 gacont(1,num_conti,i)=-fprimcont*xj
1351                 gacont(2,num_conti,i)=-fprimcont*yj
1352                 gacont(3,num_conti,i)=-fprimcont*zj
1353 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1354 cd              write (iout,'(2i3,3f10.5)')
1355 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1356               endif
1357             endif
1358           enddo      ! j
1359         enddo        ! iint
1360 C Change 12/1/95
1361         num_cont(i)=num_conti
1362       enddo          ! i
1363       do i=1,nct
1364         do j=1,3
1365           gvdwc(j,i)=expon*gvdwc(j,i)
1366           gvdwx(j,i)=expon*gvdwx(j,i)
1367         enddo
1368       enddo
1369 C******************************************************************************
1370 C
1371 C                              N O T E !!!
1372 C
1373 C To save time, the factor of EXPON has been extracted from ALL components
1374 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1375 C use!
1376 C
1377 C******************************************************************************
1378       return
1379       end
1380 C-----------------------------------------------------------------------------
1381       subroutine eljk(evdw,evdw_p,evdw_m)
1382 C
1383 C This subroutine calculates the interaction energy of nonbonded side chains
1384 C assuming the LJK potential of interaction.
1385 C
1386       implicit real*8 (a-h,o-z)
1387       include 'DIMENSIONS'
1388       include 'COMMON.GEO'
1389       include 'COMMON.VAR'
1390       include 'COMMON.LOCAL'
1391       include 'COMMON.CHAIN'
1392       include 'COMMON.DERIV'
1393       include 'COMMON.INTERACT'
1394       include 'COMMON.IOUNITS'
1395       include 'COMMON.NAMES'
1396       dimension gg(3)
1397       logical scheck
1398 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1399       evdw=0.0D0
1400       do i=iatsc_s,iatsc_e
1401         itypi=itype(i)
1402         itypi1=itype(i+1)
1403         xi=c(1,nres+i)
1404         yi=c(2,nres+i)
1405         zi=c(3,nres+i)
1406 C
1407 C Calculate SC interaction energy.
1408 C
1409         do iint=1,nint_gr(i)
1410           do j=istart(i,iint),iend(i,iint)
1411             itypj=itype(j)
1412             xj=c(1,nres+j)-xi
1413             yj=c(2,nres+j)-yi
1414             zj=c(3,nres+j)-zi
1415             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1416             fac_augm=rrij**expon
1417             e_augm=augm(itypi,itypj)*fac_augm
1418             r_inv_ij=dsqrt(rrij)
1419             rij=1.0D0/r_inv_ij
1420             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1421             fac=r_shift_inv**expon
1422             e1=fac*fac*aa(itypi,itypj)
1423             e2=fac*bb(itypi,itypj)
1424             evdwij=e_augm+e1+e2
1425 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1426 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1427 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1428 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1429 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1430 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1431 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1432 #ifdef TSCSC
1433             if (bb(itypi,itypj).gt.0) then
1434                evdw_p=evdw_p+evdwij
1435             else
1436                evdw_m=evdw_m+evdwij
1437             endif
1438 #else
1439             evdw=evdw+evdwij
1440 #endif
1441 C
1442 C Calculate the components of the gradient in DC and X
1443 C
1444             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1445             gg(1)=xj*fac
1446             gg(2)=yj*fac
1447             gg(3)=zj*fac
1448 #ifdef TSCSC
1449             if (bb(itypi,itypj).gt.0.0d0) then
1450               do k=1,3
1451                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1452                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1453                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1454                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1455               enddo
1456             else
1457               do k=1,3
1458                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1459                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1460                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1461                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1462               enddo
1463             endif
1464 #else
1465             do k=1,3
1466               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1467               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1468               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1469               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1470             enddo
1471 #endif
1472 cgrad            do k=i,j-1
1473 cgrad              do l=1,3
1474 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1475 cgrad              enddo
1476 cgrad            enddo
1477           enddo      ! j
1478         enddo        ! iint
1479       enddo          ! i
1480       do i=1,nct
1481         do j=1,3
1482           gvdwc(j,i)=expon*gvdwc(j,i)
1483           gvdwx(j,i)=expon*gvdwx(j,i)
1484         enddo
1485       enddo
1486       return
1487       end
1488 C-----------------------------------------------------------------------------
1489       subroutine ebp(evdw,evdw_p,evdw_m)
1490 C
1491 C This subroutine calculates the interaction energy of nonbonded side chains
1492 C assuming the Berne-Pechukas potential of interaction.
1493 C
1494       implicit real*8 (a-h,o-z)
1495       include 'DIMENSIONS'
1496       include 'COMMON.GEO'
1497       include 'COMMON.VAR'
1498       include 'COMMON.LOCAL'
1499       include 'COMMON.CHAIN'
1500       include 'COMMON.DERIV'
1501       include 'COMMON.NAMES'
1502       include 'COMMON.INTERACT'
1503       include 'COMMON.IOUNITS'
1504       include 'COMMON.CALC'
1505       common /srutu/ icall
1506 c     double precision rrsave(maxdim)
1507       logical lprn
1508       evdw=0.0D0
1509 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1510       evdw=0.0D0
1511 c     if (icall.eq.0) then
1512 c       lprn=.true.
1513 c     else
1514         lprn=.false.
1515 c     endif
1516       ind=0
1517       do i=iatsc_s,iatsc_e
1518         itypi=itype(i)
1519         itypi1=itype(i+1)
1520         xi=c(1,nres+i)
1521         yi=c(2,nres+i)
1522         zi=c(3,nres+i)
1523         dxi=dc_norm(1,nres+i)
1524         dyi=dc_norm(2,nres+i)
1525         dzi=dc_norm(3,nres+i)
1526 c        dsci_inv=dsc_inv(itypi)
1527         dsci_inv=vbld_inv(i+nres)
1528 C
1529 C Calculate SC interaction energy.
1530 C
1531         do iint=1,nint_gr(i)
1532           do j=istart(i,iint),iend(i,iint)
1533             ind=ind+1
1534             itypj=itype(j)
1535 c            dscj_inv=dsc_inv(itypj)
1536             dscj_inv=vbld_inv(j+nres)
1537             chi1=chi(itypi,itypj)
1538             chi2=chi(itypj,itypi)
1539             chi12=chi1*chi2
1540             chip1=chip(itypi)
1541             chip2=chip(itypj)
1542             chip12=chip1*chip2
1543             alf1=alp(itypi)
1544             alf2=alp(itypj)
1545             alf12=0.5D0*(alf1+alf2)
1546 C For diagnostics only!!!
1547 c           chi1=0.0D0
1548 c           chi2=0.0D0
1549 c           chi12=0.0D0
1550 c           chip1=0.0D0
1551 c           chip2=0.0D0
1552 c           chip12=0.0D0
1553 c           alf1=0.0D0
1554 c           alf2=0.0D0
1555 c           alf12=0.0D0
1556             xj=c(1,nres+j)-xi
1557             yj=c(2,nres+j)-yi
1558             zj=c(3,nres+j)-zi
1559             dxj=dc_norm(1,nres+j)
1560             dyj=dc_norm(2,nres+j)
1561             dzj=dc_norm(3,nres+j)
1562             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1563 cd          if (icall.eq.0) then
1564 cd            rrsave(ind)=rrij
1565 cd          else
1566 cd            rrij=rrsave(ind)
1567 cd          endif
1568             rij=dsqrt(rrij)
1569 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1570             call sc_angular
1571 C Calculate whole angle-dependent part of epsilon and contributions
1572 C to its derivatives
1573             fac=(rrij*sigsq)**expon2
1574             e1=fac*fac*aa(itypi,itypj)
1575             e2=fac*bb(itypi,itypj)
1576             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1577             eps2der=evdwij*eps3rt
1578             eps3der=evdwij*eps2rt
1579             evdwij=evdwij*eps2rt*eps3rt
1580 #ifdef TSCSC
1581             if (bb(itypi,itypj).gt.0) then
1582                evdw_p=evdw_p+evdwij
1583             else
1584                evdw_m=evdw_m+evdwij
1585             endif
1586 #else
1587             evdw=evdw+evdwij
1588 #endif
1589             if (lprn) then
1590             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1591             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1592 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1593 cd     &        restyp(itypi),i,restyp(itypj),j,
1594 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1595 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1596 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1597 cd     &        evdwij
1598             endif
1599 C Calculate gradient components.
1600             e1=e1*eps1*eps2rt**2*eps3rt**2
1601             fac=-expon*(e1+evdwij)
1602             sigder=fac/sigsq
1603             fac=rrij*fac
1604 C Calculate radial part of the gradient
1605             gg(1)=xj*fac
1606             gg(2)=yj*fac
1607             gg(3)=zj*fac
1608 C Calculate the angular part of the gradient and sum add the contributions
1609 C to the appropriate components of the Cartesian gradient.
1610 #ifdef TSCSC
1611             if (bb(itypi,itypj).gt.0) then
1612                call sc_grad
1613             else
1614                call sc_grad_T
1615             endif
1616 #else
1617             call sc_grad
1618 #endif
1619           enddo      ! j
1620         enddo        ! iint
1621       enddo          ! i
1622 c     stop
1623       return
1624       end
1625 C-----------------------------------------------------------------------------
1626       subroutine egb(evdw,evdw_p,evdw_m)
1627 C
1628 C This subroutine calculates the interaction energy of nonbonded side chains
1629 C assuming the Gay-Berne potential of interaction.
1630 C
1631       implicit real*8 (a-h,o-z)
1632       include 'DIMENSIONS'
1633       include 'COMMON.GEO'
1634       include 'COMMON.VAR'
1635       include 'COMMON.LOCAL'
1636       include 'COMMON.CHAIN'
1637       include 'COMMON.DERIV'
1638       include 'COMMON.NAMES'
1639       include 'COMMON.INTERACT'
1640       include 'COMMON.IOUNITS'
1641       include 'COMMON.CALC'
1642       include 'COMMON.CONTROL'
1643       include 'COMMON.SBRIDGE'
1644       logical lprn
1645       evdw=0.0D0
1646 ccccc      energy_dec=.false.
1647 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1648       evdw=0.0D0
1649       evdw_p=0.0D0
1650       evdw_m=0.0D0
1651       lprn=.false.
1652 c     if (icall.eq.0) lprn=.false.
1653       ind=0
1654       do i=iatsc_s,iatsc_e
1655         itypi=itype(i)
1656         itypi1=itype(i+1)
1657         xi=c(1,nres+i)
1658         yi=c(2,nres+i)
1659         zi=c(3,nres+i)
1660         dxi=dc_norm(1,nres+i)
1661         dyi=dc_norm(2,nres+i)
1662         dzi=dc_norm(3,nres+i)
1663 c        dsci_inv=dsc_inv(itypi)
1664         dsci_inv=vbld_inv(i+nres)
1665 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1666 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1667 C
1668 C Calculate SC interaction energy.
1669 C
1670         do iint=1,nint_gr(i)
1671           do j=istart(i,iint),iend(i,iint)
1672             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1673               call dyn_ssbond_ene(i,j,evdwij)
1674               evdw=evdw+evdwij
1675               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1676      &                        'evdw',i,j,evdwij,' ss'
1677             ELSE
1678             ind=ind+1
1679             itypj=itype(j)
1680 c            dscj_inv=dsc_inv(itypj)
1681             dscj_inv=vbld_inv(j+nres)
1682 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1683 c     &       1.0d0/vbld(j+nres)
1684 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1685             sig0ij=sigma(itypi,itypj)
1686             chi1=chi(itypi,itypj)
1687             chi2=chi(itypj,itypi)
1688             chi12=chi1*chi2
1689             chip1=chip(itypi)
1690             chip2=chip(itypj)
1691             chip12=chip1*chip2
1692             alf1=alp(itypi)
1693             alf2=alp(itypj)
1694             alf12=0.5D0*(alf1+alf2)
1695 C For diagnostics only!!!
1696 c           chi1=0.0D0
1697 c           chi2=0.0D0
1698 c           chi12=0.0D0
1699 c           chip1=0.0D0
1700 c           chip2=0.0D0
1701 c           chip12=0.0D0
1702 c           alf1=0.0D0
1703 c           alf2=0.0D0
1704 c           alf12=0.0D0
1705             xj=c(1,nres+j)-xi
1706             yj=c(2,nres+j)-yi
1707             zj=c(3,nres+j)-zi
1708             dxj=dc_norm(1,nres+j)
1709             dyj=dc_norm(2,nres+j)
1710             dzj=dc_norm(3,nres+j)
1711 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1712 c            write (iout,*) "j",j," dc_norm",
1713 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1714             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1715             rij=dsqrt(rrij)
1716 C Calculate angle-dependent terms of energy and contributions to their
1717 C derivatives.
1718             call sc_angular
1719             sigsq=1.0D0/sigsq
1720             sig=sig0ij*dsqrt(sigsq)
1721             rij_shift=1.0D0/rij-sig+sig0ij
1722 c for diagnostics; uncomment
1723 c            rij_shift=1.2*sig0ij
1724 C I hate to put IF's in the loops, but here don't have another choice!!!!
1725             if (rij_shift.le.0.0D0) then
1726               evdw=1.0D20
1727 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1728 cd     &        restyp(itypi),i,restyp(itypj),j,
1729 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1730               return
1731             endif
1732             sigder=-sig*sigsq
1733 c---------------------------------------------------------------
1734             rij_shift=1.0D0/rij_shift
1735             fac=rij_shift**expon
1736             e1=fac*fac*aa(itypi,itypj)
1737             e2=fac*bb(itypi,itypj)
1738             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1739             eps2der=evdwij*eps3rt
1740             eps3der=evdwij*eps2rt
1741 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1742 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1743             evdwij=evdwij*eps2rt*eps3rt
1744 #ifdef TSCSC
1745             if (bb(itypi,itypj).gt.0) then
1746                evdw_p=evdw_p+evdwij
1747             else
1748                evdw_m=evdw_m+evdwij
1749             endif
1750 #else
1751             evdw=evdw+evdwij
1752 #endif
1753             if (lprn) then
1754             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1755             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1756             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1757      &        restyp(itypi),i,restyp(itypj),j,
1758      &        epsi,sigm,chi1,chi2,chip1,chip2,
1759      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1760      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1761      &        evdwij
1762             endif
1763
1764             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1765      &                        'evdw',i,j,evdwij
1766
1767 C Calculate gradient components.
1768             e1=e1*eps1*eps2rt**2*eps3rt**2
1769             fac=-expon*(e1+evdwij)*rij_shift
1770             sigder=fac*sigder
1771             fac=rij*fac
1772 c            fac=0.0d0
1773 C Calculate the radial part of the gradient
1774             gg(1)=xj*fac
1775             gg(2)=yj*fac
1776             gg(3)=zj*fac
1777 C Calculate angular part of the gradient.
1778 #ifdef TSCSC
1779             if (bb(itypi,itypj).gt.0) then
1780                call sc_grad
1781             else
1782                call sc_grad_T
1783             endif
1784 #else
1785             call sc_grad
1786 #endif
1787             ENDIF    ! dyn_ss
1788           enddo      ! j
1789         enddo        ! iint
1790       enddo          ! i
1791 c      write (iout,*) "Number of loop steps in EGB:",ind
1792 cccc      energy_dec=.false.
1793       return
1794       end
1795 C-----------------------------------------------------------------------------
1796       subroutine egbv(evdw,evdw_p,evdw_m)
1797 C
1798 C This subroutine calculates the interaction energy of nonbonded side chains
1799 C assuming the Gay-Berne-Vorobjev potential of interaction.
1800 C
1801       implicit real*8 (a-h,o-z)
1802       include 'DIMENSIONS'
1803       include 'COMMON.GEO'
1804       include 'COMMON.VAR'
1805       include 'COMMON.LOCAL'
1806       include 'COMMON.CHAIN'
1807       include 'COMMON.DERIV'
1808       include 'COMMON.NAMES'
1809       include 'COMMON.INTERACT'
1810       include 'COMMON.IOUNITS'
1811       include 'COMMON.CALC'
1812       common /srutu/ icall
1813       logical lprn
1814       evdw=0.0D0
1815 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1816       evdw=0.0D0
1817       lprn=.false.
1818 c     if (icall.eq.0) lprn=.true.
1819       ind=0
1820       do i=iatsc_s,iatsc_e
1821         itypi=itype(i)
1822         itypi1=itype(i+1)
1823         xi=c(1,nres+i)
1824         yi=c(2,nres+i)
1825         zi=c(3,nres+i)
1826         dxi=dc_norm(1,nres+i)
1827         dyi=dc_norm(2,nres+i)
1828         dzi=dc_norm(3,nres+i)
1829 c        dsci_inv=dsc_inv(itypi)
1830         dsci_inv=vbld_inv(i+nres)
1831 C
1832 C Calculate SC interaction energy.
1833 C
1834         do iint=1,nint_gr(i)
1835           do j=istart(i,iint),iend(i,iint)
1836             ind=ind+1
1837             itypj=itype(j)
1838 c            dscj_inv=dsc_inv(itypj)
1839             dscj_inv=vbld_inv(j+nres)
1840             sig0ij=sigma(itypi,itypj)
1841             r0ij=r0(itypi,itypj)
1842             chi1=chi(itypi,itypj)
1843             chi2=chi(itypj,itypi)
1844             chi12=chi1*chi2
1845             chip1=chip(itypi)
1846             chip2=chip(itypj)
1847             chip12=chip1*chip2
1848             alf1=alp(itypi)
1849             alf2=alp(itypj)
1850             alf12=0.5D0*(alf1+alf2)
1851 C For diagnostics only!!!
1852 c           chi1=0.0D0
1853 c           chi2=0.0D0
1854 c           chi12=0.0D0
1855 c           chip1=0.0D0
1856 c           chip2=0.0D0
1857 c           chip12=0.0D0
1858 c           alf1=0.0D0
1859 c           alf2=0.0D0
1860 c           alf12=0.0D0
1861             xj=c(1,nres+j)-xi
1862             yj=c(2,nres+j)-yi
1863             zj=c(3,nres+j)-zi
1864             dxj=dc_norm(1,nres+j)
1865             dyj=dc_norm(2,nres+j)
1866             dzj=dc_norm(3,nres+j)
1867             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1868             rij=dsqrt(rrij)
1869 C Calculate angle-dependent terms of energy and contributions to their
1870 C derivatives.
1871             call sc_angular
1872             sigsq=1.0D0/sigsq
1873             sig=sig0ij*dsqrt(sigsq)
1874             rij_shift=1.0D0/rij-sig+r0ij
1875 C I hate to put IF's in the loops, but here don't have another choice!!!!
1876             if (rij_shift.le.0.0D0) then
1877               evdw=1.0D20
1878               return
1879             endif
1880             sigder=-sig*sigsq
1881 c---------------------------------------------------------------
1882             rij_shift=1.0D0/rij_shift
1883             fac=rij_shift**expon
1884             e1=fac*fac*aa(itypi,itypj)
1885             e2=fac*bb(itypi,itypj)
1886             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1887             eps2der=evdwij*eps3rt
1888             eps3der=evdwij*eps2rt
1889             fac_augm=rrij**expon
1890             e_augm=augm(itypi,itypj)*fac_augm
1891             evdwij=evdwij*eps2rt*eps3rt
1892 #ifdef TSCSC
1893             if (bb(itypi,itypj).gt.0) then
1894                evdw_p=evdw_p+evdwij+e_augm
1895             else
1896                evdw_m=evdw_m+evdwij+e_augm
1897             endif
1898 #else
1899             evdw=evdw+evdwij+e_augm
1900 #endif
1901             if (lprn) then
1902             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1903             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1904             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1905      &        restyp(itypi),i,restyp(itypj),j,
1906      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1907      &        chi1,chi2,chip1,chip2,
1908      &        eps1,eps2rt**2,eps3rt**2,
1909      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1910      &        evdwij+e_augm
1911             endif
1912 C Calculate gradient components.
1913             e1=e1*eps1*eps2rt**2*eps3rt**2
1914             fac=-expon*(e1+evdwij)*rij_shift
1915             sigder=fac*sigder
1916             fac=rij*fac-2*expon*rrij*e_augm
1917 C Calculate the radial part of the gradient
1918             gg(1)=xj*fac
1919             gg(2)=yj*fac
1920             gg(3)=zj*fac
1921 C Calculate angular part of the gradient.
1922 #ifdef TSCSC
1923             if (bb(itypi,itypj).gt.0) then
1924                call sc_grad
1925             else
1926                call sc_grad_T
1927             endif
1928 #else
1929             call sc_grad
1930 #endif
1931           enddo      ! j
1932         enddo        ! iint
1933       enddo          ! i
1934       end
1935 C-----------------------------------------------------------------------------
1936       subroutine sc_angular
1937 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1938 C om12. Called by ebp, egb, and egbv.
1939       implicit none
1940       include 'COMMON.CALC'
1941       include 'COMMON.IOUNITS'
1942       erij(1)=xj*rij
1943       erij(2)=yj*rij
1944       erij(3)=zj*rij
1945       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1946       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1947       om12=dxi*dxj+dyi*dyj+dzi*dzj
1948       chiom12=chi12*om12
1949 C Calculate eps1(om12) and its derivative in om12
1950       faceps1=1.0D0-om12*chiom12
1951       faceps1_inv=1.0D0/faceps1
1952       eps1=dsqrt(faceps1_inv)
1953 C Following variable is eps1*deps1/dom12
1954       eps1_om12=faceps1_inv*chiom12
1955 c diagnostics only
1956 c      faceps1_inv=om12
1957 c      eps1=om12
1958 c      eps1_om12=1.0d0
1959 c      write (iout,*) "om12",om12," eps1",eps1
1960 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1961 C and om12.
1962       om1om2=om1*om2
1963       chiom1=chi1*om1
1964       chiom2=chi2*om2
1965       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1966       sigsq=1.0D0-facsig*faceps1_inv
1967       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1968       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1969       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1970 c diagnostics only
1971 c      sigsq=1.0d0
1972 c      sigsq_om1=0.0d0
1973 c      sigsq_om2=0.0d0
1974 c      sigsq_om12=0.0d0
1975 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1976 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1977 c     &    " eps1",eps1
1978 C Calculate eps2 and its derivatives in om1, om2, and om12.
1979       chipom1=chip1*om1
1980       chipom2=chip2*om2
1981       chipom12=chip12*om12
1982       facp=1.0D0-om12*chipom12
1983       facp_inv=1.0D0/facp
1984       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1985 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1986 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1987 C Following variable is the square root of eps2
1988       eps2rt=1.0D0-facp1*facp_inv
1989 C Following three variables are the derivatives of the square root of eps
1990 C in om1, om2, and om12.
1991       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1992       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1993       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1994 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1995       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1996 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1997 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1998 c     &  " eps2rt_om12",eps2rt_om12
1999 C Calculate whole angle-dependent part of epsilon and contributions
2000 C to its derivatives
2001       return
2002       end
2003
2004 C----------------------------------------------------------------------------
2005       subroutine sc_grad_T
2006       implicit real*8 (a-h,o-z)
2007       include 'DIMENSIONS'
2008       include 'COMMON.CHAIN'
2009       include 'COMMON.DERIV'
2010       include 'COMMON.CALC'
2011       include 'COMMON.IOUNITS'
2012       double precision dcosom1(3),dcosom2(3)
2013       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2014       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2015       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2016      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2017 c diagnostics only
2018 c      eom1=0.0d0
2019 c      eom2=0.0d0
2020 c      eom12=evdwij*eps1_om12
2021 c end diagnostics
2022 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2023 c     &  " sigder",sigder
2024 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2025 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2026       do k=1,3
2027         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2028         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2029       enddo
2030       do k=1,3
2031         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2032       enddo
2033 c      write (iout,*) "gg",(gg(k),k=1,3)
2034       do k=1,3
2035         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
2036      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2037      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2038         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
2039      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2040      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2041 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2042 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2043 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2044 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2045       enddo
2046 C
2047 C Calculate the components of the gradient in DC and X
2048 C
2049 cgrad      do k=i,j-1
2050 cgrad        do l=1,3
2051 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2052 cgrad        enddo
2053 cgrad      enddo
2054       do l=1,3
2055         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
2056         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
2057       enddo
2058       return
2059       end
2060
2061 C----------------------------------------------------------------------------
2062       subroutine sc_grad
2063       implicit real*8 (a-h,o-z)
2064       include 'DIMENSIONS'
2065       include 'COMMON.CHAIN'
2066       include 'COMMON.DERIV'
2067       include 'COMMON.CALC'
2068       include 'COMMON.IOUNITS'
2069       double precision dcosom1(3),dcosom2(3)
2070       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2071       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2072       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2073      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2074 c diagnostics only
2075 c      eom1=0.0d0
2076 c      eom2=0.0d0
2077 c      eom12=evdwij*eps1_om12
2078 c end diagnostics
2079 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2080 c     &  " sigder",sigder
2081 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2082 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2083       do k=1,3
2084         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2085         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2086       enddo
2087       do k=1,3
2088         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2089       enddo
2090 c      write (iout,*) "gg",(gg(k),k=1,3)
2091       do k=1,3
2092         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2093      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2094      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2095         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2096      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2097      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2098 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2099 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2100 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2101 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2102       enddo
2103 C
2104 C Calculate the components of the gradient in DC and X
2105 C
2106 cgrad      do k=i,j-1
2107 cgrad        do l=1,3
2108 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2109 cgrad        enddo
2110 cgrad      enddo
2111       do l=1,3
2112         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2113         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2114       enddo
2115       return
2116       end
2117 C-----------------------------------------------------------------------
2118       subroutine e_softsphere(evdw)
2119 C
2120 C This subroutine calculates the interaction energy of nonbonded side chains
2121 C assuming the LJ potential of interaction.
2122 C
2123       implicit real*8 (a-h,o-z)
2124       include 'DIMENSIONS'
2125       parameter (accur=1.0d-10)
2126       include 'COMMON.GEO'
2127       include 'COMMON.VAR'
2128       include 'COMMON.LOCAL'
2129       include 'COMMON.CHAIN'
2130       include 'COMMON.DERIV'
2131       include 'COMMON.INTERACT'
2132       include 'COMMON.TORSION'
2133       include 'COMMON.SBRIDGE'
2134       include 'COMMON.NAMES'
2135       include 'COMMON.IOUNITS'
2136       include 'COMMON.CONTACTS'
2137       dimension gg(3)
2138 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2139       evdw=0.0D0
2140       do i=iatsc_s,iatsc_e
2141         itypi=itype(i)
2142         itypi1=itype(i+1)
2143         xi=c(1,nres+i)
2144         yi=c(2,nres+i)
2145         zi=c(3,nres+i)
2146 C
2147 C Calculate SC interaction energy.
2148 C
2149         do iint=1,nint_gr(i)
2150 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2151 cd   &                  'iend=',iend(i,iint)
2152           do j=istart(i,iint),iend(i,iint)
2153             itypj=itype(j)
2154             xj=c(1,nres+j)-xi
2155             yj=c(2,nres+j)-yi
2156             zj=c(3,nres+j)-zi
2157             rij=xj*xj+yj*yj+zj*zj
2158 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2159             r0ij=r0(itypi,itypj)
2160             r0ijsq=r0ij*r0ij
2161 c            print *,i,j,r0ij,dsqrt(rij)
2162             if (rij.lt.r0ijsq) then
2163               evdwij=0.25d0*(rij-r0ijsq)**2
2164               fac=rij-r0ijsq
2165             else
2166               evdwij=0.0d0
2167               fac=0.0d0
2168             endif
2169             evdw=evdw+evdwij
2170 C
2171 C Calculate the components of the gradient in DC and X
2172 C
2173             gg(1)=xj*fac
2174             gg(2)=yj*fac
2175             gg(3)=zj*fac
2176             do k=1,3
2177               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2178               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2179               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2180               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2181             enddo
2182 cgrad            do k=i,j-1
2183 cgrad              do l=1,3
2184 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2185 cgrad              enddo
2186 cgrad            enddo
2187           enddo ! j
2188         enddo ! iint
2189       enddo ! i
2190       return
2191       end
2192 C--------------------------------------------------------------------------
2193       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2194      &              eello_turn4)
2195 C
2196 C Soft-sphere potential of p-p interaction
2197 C
2198       implicit real*8 (a-h,o-z)
2199       include 'DIMENSIONS'
2200       include 'COMMON.CONTROL'
2201       include 'COMMON.IOUNITS'
2202       include 'COMMON.GEO'
2203       include 'COMMON.VAR'
2204       include 'COMMON.LOCAL'
2205       include 'COMMON.CHAIN'
2206       include 'COMMON.DERIV'
2207       include 'COMMON.INTERACT'
2208       include 'COMMON.CONTACTS'
2209       include 'COMMON.TORSION'
2210       include 'COMMON.VECTORS'
2211       include 'COMMON.FFIELD'
2212       dimension ggg(3)
2213 cd      write(iout,*) 'In EELEC_soft_sphere'
2214       ees=0.0D0
2215       evdw1=0.0D0
2216       eel_loc=0.0d0
2217       eello_turn3=0.0d0
2218       eello_turn4=0.0d0
2219       ind=0
2220       do i=iatel_s,iatel_e
2221         dxi=dc(1,i)
2222         dyi=dc(2,i)
2223         dzi=dc(3,i)
2224         xmedi=c(1,i)+0.5d0*dxi
2225         ymedi=c(2,i)+0.5d0*dyi
2226         zmedi=c(3,i)+0.5d0*dzi
2227         num_conti=0
2228 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2229         do j=ielstart(i),ielend(i)
2230           ind=ind+1
2231           iteli=itel(i)
2232           itelj=itel(j)
2233           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2234           r0ij=rpp(iteli,itelj)
2235           r0ijsq=r0ij*r0ij
2236           dxj=dc(1,j)
2237           dyj=dc(2,j)
2238           dzj=dc(3,j)
2239           xj=c(1,j)+0.5D0*dxj-xmedi
2240           yj=c(2,j)+0.5D0*dyj-ymedi
2241           zj=c(3,j)+0.5D0*dzj-zmedi
2242           rij=xj*xj+yj*yj+zj*zj
2243           if (rij.lt.r0ijsq) then
2244             evdw1ij=0.25d0*(rij-r0ijsq)**2
2245             fac=rij-r0ijsq
2246           else
2247             evdw1ij=0.0d0
2248             fac=0.0d0
2249           endif
2250           evdw1=evdw1+evdw1ij
2251 C
2252 C Calculate contributions to the Cartesian gradient.
2253 C
2254           ggg(1)=fac*xj
2255           ggg(2)=fac*yj
2256           ggg(3)=fac*zj
2257           do k=1,3
2258             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2259             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2260           enddo
2261 *
2262 * Loop over residues i+1 thru j-1.
2263 *
2264 cgrad          do k=i+1,j-1
2265 cgrad            do l=1,3
2266 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2267 cgrad            enddo
2268 cgrad          enddo
2269         enddo ! j
2270       enddo   ! i
2271 cgrad      do i=nnt,nct-1
2272 cgrad        do k=1,3
2273 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2274 cgrad        enddo
2275 cgrad        do j=i+1,nct-1
2276 cgrad          do k=1,3
2277 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2278 cgrad          enddo
2279 cgrad        enddo
2280 cgrad      enddo
2281       return
2282       end
2283 c------------------------------------------------------------------------------
2284       subroutine vec_and_deriv
2285       implicit real*8 (a-h,o-z)
2286       include 'DIMENSIONS'
2287 #ifdef MPI
2288       include 'mpif.h'
2289 #endif
2290       include 'COMMON.IOUNITS'
2291       include 'COMMON.GEO'
2292       include 'COMMON.VAR'
2293       include 'COMMON.LOCAL'
2294       include 'COMMON.CHAIN'
2295       include 'COMMON.VECTORS'
2296       include 'COMMON.SETUP'
2297       include 'COMMON.TIME1'
2298       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2299 C Compute the local reference systems. For reference system (i), the
2300 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2301 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2302 #ifdef PARVEC
2303       do i=ivec_start,ivec_end
2304 #else
2305       do i=1,nres-1
2306 #endif
2307           if (i.eq.nres-1) then
2308 C Case of the last full residue
2309 C Compute the Z-axis
2310             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2311             costh=dcos(pi-theta(nres))
2312             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2313             do k=1,3
2314               uz(k,i)=fac*uz(k,i)
2315             enddo
2316 C Compute the derivatives of uz
2317             uzder(1,1,1)= 0.0d0
2318             uzder(2,1,1)=-dc_norm(3,i-1)
2319             uzder(3,1,1)= dc_norm(2,i-1)
2320             uzder(1,2,1)= dc_norm(3,i-1)
2321             uzder(2,2,1)= 0.0d0
2322             uzder(3,2,1)=-dc_norm(1,i-1)
2323             uzder(1,3,1)=-dc_norm(2,i-1)
2324             uzder(2,3,1)= dc_norm(1,i-1)
2325             uzder(3,3,1)= 0.0d0
2326             uzder(1,1,2)= 0.0d0
2327             uzder(2,1,2)= dc_norm(3,i)
2328             uzder(3,1,2)=-dc_norm(2,i)
2329             uzder(1,2,2)=-dc_norm(3,i)
2330             uzder(2,2,2)= 0.0d0
2331             uzder(3,2,2)= dc_norm(1,i)
2332             uzder(1,3,2)= dc_norm(2,i)
2333             uzder(2,3,2)=-dc_norm(1,i)
2334             uzder(3,3,2)= 0.0d0
2335 C Compute the Y-axis
2336             facy=fac
2337             do k=1,3
2338               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2339             enddo
2340 C Compute the derivatives of uy
2341             do j=1,3
2342               do k=1,3
2343                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2344      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2345                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2346               enddo
2347               uyder(j,j,1)=uyder(j,j,1)-costh
2348               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2349             enddo
2350             do j=1,2
2351               do k=1,3
2352                 do l=1,3
2353                   uygrad(l,k,j,i)=uyder(l,k,j)
2354                   uzgrad(l,k,j,i)=uzder(l,k,j)
2355                 enddo
2356               enddo
2357             enddo
2358             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2359             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2360             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2361             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2362           else
2363 C Other residues
2364 C Compute the Z-axis
2365             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2366             costh=dcos(pi-theta(i+2))
2367             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2368             do k=1,3
2369               uz(k,i)=fac*uz(k,i)
2370             enddo
2371 C Compute the derivatives of uz
2372             uzder(1,1,1)= 0.0d0
2373             uzder(2,1,1)=-dc_norm(3,i+1)
2374             uzder(3,1,1)= dc_norm(2,i+1)
2375             uzder(1,2,1)= dc_norm(3,i+1)
2376             uzder(2,2,1)= 0.0d0
2377             uzder(3,2,1)=-dc_norm(1,i+1)
2378             uzder(1,3,1)=-dc_norm(2,i+1)
2379             uzder(2,3,1)= dc_norm(1,i+1)
2380             uzder(3,3,1)= 0.0d0
2381             uzder(1,1,2)= 0.0d0
2382             uzder(2,1,2)= dc_norm(3,i)
2383             uzder(3,1,2)=-dc_norm(2,i)
2384             uzder(1,2,2)=-dc_norm(3,i)
2385             uzder(2,2,2)= 0.0d0
2386             uzder(3,2,2)= dc_norm(1,i)
2387             uzder(1,3,2)= dc_norm(2,i)
2388             uzder(2,3,2)=-dc_norm(1,i)
2389             uzder(3,3,2)= 0.0d0
2390 C Compute the Y-axis
2391             facy=fac
2392             do k=1,3
2393               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2394             enddo
2395 C Compute the derivatives of uy
2396             do j=1,3
2397               do k=1,3
2398                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2399      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2400                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2401               enddo
2402               uyder(j,j,1)=uyder(j,j,1)-costh
2403               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2404             enddo
2405             do j=1,2
2406               do k=1,3
2407                 do l=1,3
2408                   uygrad(l,k,j,i)=uyder(l,k,j)
2409                   uzgrad(l,k,j,i)=uzder(l,k,j)
2410                 enddo
2411               enddo
2412             enddo
2413             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2414             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2415             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2416             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2417           endif
2418       enddo
2419       do i=1,nres-1
2420         vbld_inv_temp(1)=vbld_inv(i+1)
2421         if (i.lt.nres-1) then
2422           vbld_inv_temp(2)=vbld_inv(i+2)
2423           else
2424           vbld_inv_temp(2)=vbld_inv(i)
2425           endif
2426         do j=1,2
2427           do k=1,3
2428             do l=1,3
2429               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2430               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2431             enddo
2432           enddo
2433         enddo
2434       enddo
2435 #if defined(PARVEC) && defined(MPI)
2436       if (nfgtasks1.gt.1) then
2437         time00=MPI_Wtime()
2438 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2439 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2440 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2441         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2442      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2443      &   FG_COMM1,IERR)
2444         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2445      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2446      &   FG_COMM1,IERR)
2447         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2448      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2449      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2450         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2451      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2452      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2453         time_gather=time_gather+MPI_Wtime()-time00
2454       endif
2455 c      if (fg_rank.eq.0) then
2456 c        write (iout,*) "Arrays UY and UZ"
2457 c        do i=1,nres-1
2458 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2459 c     &     (uz(k,i),k=1,3)
2460 c        enddo
2461 c      endif
2462 #endif
2463       return
2464       end
2465 C-----------------------------------------------------------------------------
2466       subroutine check_vecgrad
2467       implicit real*8 (a-h,o-z)
2468       include 'DIMENSIONS'
2469       include 'COMMON.IOUNITS'
2470       include 'COMMON.GEO'
2471       include 'COMMON.VAR'
2472       include 'COMMON.LOCAL'
2473       include 'COMMON.CHAIN'
2474       include 'COMMON.VECTORS'
2475       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2476       dimension uyt(3,maxres),uzt(3,maxres)
2477       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2478       double precision delta /1.0d-7/
2479       call vec_and_deriv
2480 cd      do i=1,nres
2481 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2482 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2483 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2484 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2485 cd     &     (dc_norm(if90,i),if90=1,3)
2486 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2487 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2488 cd          write(iout,'(a)')
2489 cd      enddo
2490       do i=1,nres
2491         do j=1,2
2492           do k=1,3
2493             do l=1,3
2494               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2495               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2496             enddo
2497           enddo
2498         enddo
2499       enddo
2500       call vec_and_deriv
2501       do i=1,nres
2502         do j=1,3
2503           uyt(j,i)=uy(j,i)
2504           uzt(j,i)=uz(j,i)
2505         enddo
2506       enddo
2507       do i=1,nres
2508 cd        write (iout,*) 'i=',i
2509         do k=1,3
2510           erij(k)=dc_norm(k,i)
2511         enddo
2512         do j=1,3
2513           do k=1,3
2514             dc_norm(k,i)=erij(k)
2515           enddo
2516           dc_norm(j,i)=dc_norm(j,i)+delta
2517 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2518 c          do k=1,3
2519 c            dc_norm(k,i)=dc_norm(k,i)/fac
2520 c          enddo
2521 c          write (iout,*) (dc_norm(k,i),k=1,3)
2522 c          write (iout,*) (erij(k),k=1,3)
2523           call vec_and_deriv
2524           do k=1,3
2525             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2526             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2527             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2528             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2529           enddo
2530 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2531 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2532 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2533         enddo
2534         do k=1,3
2535           dc_norm(k,i)=erij(k)
2536         enddo
2537 cd        do k=1,3
2538 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2539 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2540 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2541 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2542 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2543 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2544 cd          write (iout,'(a)')
2545 cd        enddo
2546       enddo
2547       return
2548       end
2549 C--------------------------------------------------------------------------
2550       subroutine set_matrices
2551       implicit real*8 (a-h,o-z)
2552       include 'DIMENSIONS'
2553 #ifdef MPI
2554       include "mpif.h"
2555       include "COMMON.SETUP"
2556       integer IERR
2557       integer status(MPI_STATUS_SIZE)
2558 #endif
2559       include 'COMMON.IOUNITS'
2560       include 'COMMON.GEO'
2561       include 'COMMON.VAR'
2562       include 'COMMON.LOCAL'
2563       include 'COMMON.CHAIN'
2564       include 'COMMON.DERIV'
2565       include 'COMMON.INTERACT'
2566       include 'COMMON.CONTACTS'
2567       include 'COMMON.TORSION'
2568       include 'COMMON.VECTORS'
2569       include 'COMMON.FFIELD'
2570       double precision auxvec(2),auxmat(2,2)
2571 C
2572 C Compute the virtual-bond-torsional-angle dependent quantities needed
2573 C to calculate the el-loc multibody terms of various order.
2574 C
2575 #ifdef PARMAT
2576       do i=ivec_start+2,ivec_end+2
2577 #else
2578       do i=3,nres+1
2579 #endif
2580         if (i .lt. nres+1) then
2581           sin1=dsin(phi(i))
2582           cos1=dcos(phi(i))
2583           sintab(i-2)=sin1
2584           costab(i-2)=cos1
2585           obrot(1,i-2)=cos1
2586           obrot(2,i-2)=sin1
2587           sin2=dsin(2*phi(i))
2588           cos2=dcos(2*phi(i))
2589           sintab2(i-2)=sin2
2590           costab2(i-2)=cos2
2591           obrot2(1,i-2)=cos2
2592           obrot2(2,i-2)=sin2
2593           Ug(1,1,i-2)=-cos1
2594           Ug(1,2,i-2)=-sin1
2595           Ug(2,1,i-2)=-sin1
2596           Ug(2,2,i-2)= cos1
2597           Ug2(1,1,i-2)=-cos2
2598           Ug2(1,2,i-2)=-sin2
2599           Ug2(2,1,i-2)=-sin2
2600           Ug2(2,2,i-2)= cos2
2601         else
2602           costab(i-2)=1.0d0
2603           sintab(i-2)=0.0d0
2604           obrot(1,i-2)=1.0d0
2605           obrot(2,i-2)=0.0d0
2606           obrot2(1,i-2)=0.0d0
2607           obrot2(2,i-2)=0.0d0
2608           Ug(1,1,i-2)=1.0d0
2609           Ug(1,2,i-2)=0.0d0
2610           Ug(2,1,i-2)=0.0d0
2611           Ug(2,2,i-2)=1.0d0
2612           Ug2(1,1,i-2)=0.0d0
2613           Ug2(1,2,i-2)=0.0d0
2614           Ug2(2,1,i-2)=0.0d0
2615           Ug2(2,2,i-2)=0.0d0
2616         endif
2617         if (i .gt. 3 .and. i .lt. nres+1) then
2618           obrot_der(1,i-2)=-sin1
2619           obrot_der(2,i-2)= cos1
2620           Ugder(1,1,i-2)= sin1
2621           Ugder(1,2,i-2)=-cos1
2622           Ugder(2,1,i-2)=-cos1
2623           Ugder(2,2,i-2)=-sin1
2624           dwacos2=cos2+cos2
2625           dwasin2=sin2+sin2
2626           obrot2_der(1,i-2)=-dwasin2
2627           obrot2_der(2,i-2)= dwacos2
2628           Ug2der(1,1,i-2)= dwasin2
2629           Ug2der(1,2,i-2)=-dwacos2
2630           Ug2der(2,1,i-2)=-dwacos2
2631           Ug2der(2,2,i-2)=-dwasin2
2632         else
2633           obrot_der(1,i-2)=0.0d0
2634           obrot_der(2,i-2)=0.0d0
2635           Ugder(1,1,i-2)=0.0d0
2636           Ugder(1,2,i-2)=0.0d0
2637           Ugder(2,1,i-2)=0.0d0
2638           Ugder(2,2,i-2)=0.0d0
2639           obrot2_der(1,i-2)=0.0d0
2640           obrot2_der(2,i-2)=0.0d0
2641           Ug2der(1,1,i-2)=0.0d0
2642           Ug2der(1,2,i-2)=0.0d0
2643           Ug2der(2,1,i-2)=0.0d0
2644           Ug2der(2,2,i-2)=0.0d0
2645         endif
2646 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2647         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2648           iti = itortyp(itype(i-2))
2649         else
2650           iti=ntortyp+1
2651         endif
2652 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2653         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2654           iti1 = itortyp(itype(i-1))
2655         else
2656           iti1=ntortyp+1
2657         endif
2658 cd        write (iout,*) '*******i',i,' iti1',iti
2659 cd        write (iout,*) 'b1',b1(:,iti)
2660 cd        write (iout,*) 'b2',b2(:,iti)
2661 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2662 c        if (i .gt. iatel_s+2) then
2663         if (i .gt. nnt+2) then
2664           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2665           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2666           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2667      &    then
2668           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2669           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2670           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2671           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2672           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2673           endif
2674         else
2675           do k=1,2
2676             Ub2(k,i-2)=0.0d0
2677             Ctobr(k,i-2)=0.0d0
2678             Dtobr2(k,i-2)=0.0d0
2679             do l=1,2
2680               EUg(l,k,i-2)=0.0d0
2681               CUg(l,k,i-2)=0.0d0
2682               DUg(l,k,i-2)=0.0d0
2683               DtUg2(l,k,i-2)=0.0d0
2684             enddo
2685           enddo
2686         endif
2687         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2688         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2689         do k=1,2
2690           muder(k,i-2)=Ub2der(k,i-2)
2691         enddo
2692 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2693         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2694           iti1 = itortyp(itype(i-1))
2695         else
2696           iti1=ntortyp+1
2697         endif
2698         do k=1,2
2699           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2700         enddo
2701 cd        write (iout,*) 'mu ',mu(:,i-2)
2702 cd        write (iout,*) 'mu1',mu1(:,i-2)
2703 cd        write (iout,*) 'mu2',mu2(:,i-2)
2704         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2705      &  then
2706         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2707         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2708         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2709         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2710         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2711 C Vectors and matrices dependent on a single virtual-bond dihedral.
2712         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2713         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2714         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2715         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2716         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2717         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2718         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2719         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2720         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2721         endif
2722       enddo
2723 C Matrices dependent on two consecutive virtual-bond dihedrals.
2724 C The order of matrices is from left to right.
2725       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2726      &then
2727 c      do i=max0(ivec_start,2),ivec_end
2728       do i=2,nres-1
2729         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2730         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2731         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2732         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2733         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2734         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2735         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2736         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2737       enddo
2738       endif
2739 #if defined(MPI) && defined(PARMAT)
2740 #ifdef DEBUG
2741 c      if (fg_rank.eq.0) then
2742         write (iout,*) "Arrays UG and UGDER before GATHER"
2743         do i=1,nres-1
2744           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2745      &     ((ug(l,k,i),l=1,2),k=1,2),
2746      &     ((ugder(l,k,i),l=1,2),k=1,2)
2747         enddo
2748         write (iout,*) "Arrays UG2 and UG2DER"
2749         do i=1,nres-1
2750           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2751      &     ((ug2(l,k,i),l=1,2),k=1,2),
2752      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2753         enddo
2754         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2755         do i=1,nres-1
2756           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2757      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2758      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2759         enddo
2760         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2761         do i=1,nres-1
2762           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2763      &     costab(i),sintab(i),costab2(i),sintab2(i)
2764         enddo
2765         write (iout,*) "Array MUDER"
2766         do i=1,nres-1
2767           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2768         enddo
2769 c      endif
2770 #endif
2771       if (nfgtasks.gt.1) then
2772         time00=MPI_Wtime()
2773 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2774 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2775 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2776 #ifdef MATGATHER
2777         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2778      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2779      &   FG_COMM1,IERR)
2780         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2781      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2782      &   FG_COMM1,IERR)
2783         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2784      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2785      &   FG_COMM1,IERR)
2786         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2787      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2788      &   FG_COMM1,IERR)
2789         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2790      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2791      &   FG_COMM1,IERR)
2792         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2793      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2794      &   FG_COMM1,IERR)
2795         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2796      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2797      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2798         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2799      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2800      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2801         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2802      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2803      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2804         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2805      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2806      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2807         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2808      &  then
2809         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2810      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2811      &   FG_COMM1,IERR)
2812         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2813      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2814      &   FG_COMM1,IERR)
2815         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2816      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2817      &   FG_COMM1,IERR)
2818        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2819      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2820      &   FG_COMM1,IERR)
2821         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2822      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2823      &   FG_COMM1,IERR)
2824         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2825      &   ivec_count(fg_rank1),
2826      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2827      &   FG_COMM1,IERR)
2828         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2829      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2830      &   FG_COMM1,IERR)
2831         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2832      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2833      &   FG_COMM1,IERR)
2834         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2835      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2836      &   FG_COMM1,IERR)
2837         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2838      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2839      &   FG_COMM1,IERR)
2840         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2841      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2842      &   FG_COMM1,IERR)
2843         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2844      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2845      &   FG_COMM1,IERR)
2846         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2847      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2848      &   FG_COMM1,IERR)
2849         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2850      &   ivec_count(fg_rank1),
2851      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2852      &   FG_COMM1,IERR)
2853         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2854      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2855      &   FG_COMM1,IERR)
2856        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2857      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2858      &   FG_COMM1,IERR)
2859         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2860      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2861      &   FG_COMM1,IERR)
2862        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2863      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2864      &   FG_COMM1,IERR)
2865         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2866      &   ivec_count(fg_rank1),
2867      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2868      &   FG_COMM1,IERR)
2869         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2870      &   ivec_count(fg_rank1),
2871      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2872      &   FG_COMM1,IERR)
2873         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2874      &   ivec_count(fg_rank1),
2875      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2876      &   MPI_MAT2,FG_COMM1,IERR)
2877         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2878      &   ivec_count(fg_rank1),
2879      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2880      &   MPI_MAT2,FG_COMM1,IERR)
2881         endif
2882 #else
2883 c Passes matrix info through the ring
2884       isend=fg_rank1
2885       irecv=fg_rank1-1
2886       if (irecv.lt.0) irecv=nfgtasks1-1
2887       iprev=irecv
2888       inext=fg_rank1+1
2889       if (inext.ge.nfgtasks1) inext=0
2890       do i=1,nfgtasks1-1
2891 c        write (iout,*) "isend",isend," irecv",irecv
2892 c        call flush(iout)
2893         lensend=lentyp(isend)
2894         lenrecv=lentyp(irecv)
2895 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2896 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2897 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2898 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2899 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2900 c        write (iout,*) "Gather ROTAT1"
2901 c        call flush(iout)
2902 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2903 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2904 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2905 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2906 c        write (iout,*) "Gather ROTAT2"
2907 c        call flush(iout)
2908         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2909      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2910      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2911      &   iprev,4400+irecv,FG_COMM,status,IERR)
2912 c        write (iout,*) "Gather ROTAT_OLD"
2913 c        call flush(iout)
2914         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2915      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2916      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2917      &   iprev,5500+irecv,FG_COMM,status,IERR)
2918 c        write (iout,*) "Gather PRECOMP11"
2919 c        call flush(iout)
2920         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2921      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2922      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2923      &   iprev,6600+irecv,FG_COMM,status,IERR)
2924 c        write (iout,*) "Gather PRECOMP12"
2925 c        call flush(iout)
2926         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2927      &  then
2928         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2929      &   MPI_ROTAT2(lensend),inext,7700+isend,
2930      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2931      &   iprev,7700+irecv,FG_COMM,status,IERR)
2932 c        write (iout,*) "Gather PRECOMP21"
2933 c        call flush(iout)
2934         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2935      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2936      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2937      &   iprev,8800+irecv,FG_COMM,status,IERR)
2938 c        write (iout,*) "Gather PRECOMP22"
2939 c        call flush(iout)
2940         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2941      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2942      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2943      &   MPI_PRECOMP23(lenrecv),
2944      &   iprev,9900+irecv,FG_COMM,status,IERR)
2945 c        write (iout,*) "Gather PRECOMP23"
2946 c        call flush(iout)
2947         endif
2948         isend=irecv
2949         irecv=irecv-1
2950         if (irecv.lt.0) irecv=nfgtasks1-1
2951       enddo
2952 #endif
2953         time_gather=time_gather+MPI_Wtime()-time00
2954       endif
2955 #ifdef DEBUG
2956 c      if (fg_rank.eq.0) then
2957         write (iout,*) "Arrays UG and UGDER"
2958         do i=1,nres-1
2959           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2960      &     ((ug(l,k,i),l=1,2),k=1,2),
2961      &     ((ugder(l,k,i),l=1,2),k=1,2)
2962         enddo
2963         write (iout,*) "Arrays UG2 and UG2DER"
2964         do i=1,nres-1
2965           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2966      &     ((ug2(l,k,i),l=1,2),k=1,2),
2967      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2968         enddo
2969         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2970         do i=1,nres-1
2971           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2972      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2973      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2974         enddo
2975         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2976         do i=1,nres-1
2977           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2978      &     costab(i),sintab(i),costab2(i),sintab2(i)
2979         enddo
2980         write (iout,*) "Array MUDER"
2981         do i=1,nres-1
2982           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2983         enddo
2984 c      endif
2985 #endif
2986 #endif
2987 cd      do i=1,nres
2988 cd        iti = itortyp(itype(i))
2989 cd        write (iout,*) i
2990 cd        do j=1,2
2991 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2992 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2993 cd        enddo
2994 cd      enddo
2995       return
2996       end
2997 C--------------------------------------------------------------------------
2998       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2999 C
3000 C This subroutine calculates the average interaction energy and its gradient
3001 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3002 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3003 C The potential depends both on the distance of peptide-group centers and on
3004 C the orientation of the CA-CA virtual bonds.
3005 C
3006       implicit real*8 (a-h,o-z)
3007 #ifdef MPI
3008       include 'mpif.h'
3009 #endif
3010       include 'DIMENSIONS'
3011       include 'COMMON.CONTROL'
3012       include 'COMMON.SETUP'
3013       include 'COMMON.IOUNITS'
3014       include 'COMMON.GEO'
3015       include 'COMMON.VAR'
3016       include 'COMMON.LOCAL'
3017       include 'COMMON.CHAIN'
3018       include 'COMMON.DERIV'
3019       include 'COMMON.INTERACT'
3020       include 'COMMON.CONTACTS'
3021       include 'COMMON.TORSION'
3022       include 'COMMON.VECTORS'
3023       include 'COMMON.FFIELD'
3024       include 'COMMON.TIME1'
3025       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3026      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3027       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3028      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3029       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3030      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3031      &    num_conti,j1,j2
3032 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3033 #ifdef MOMENT
3034       double precision scal_el /1.0d0/
3035 #else
3036       double precision scal_el /0.5d0/
3037 #endif
3038 C 12/13/98
3039 C 13-go grudnia roku pamietnego...
3040       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3041      &                   0.0d0,1.0d0,0.0d0,
3042      &                   0.0d0,0.0d0,1.0d0/
3043 cd      write(iout,*) 'In EELEC'
3044 cd      do i=1,nloctyp
3045 cd        write(iout,*) 'Type',i
3046 cd        write(iout,*) 'B1',B1(:,i)
3047 cd        write(iout,*) 'B2',B2(:,i)
3048 cd        write(iout,*) 'CC',CC(:,:,i)
3049 cd        write(iout,*) 'DD',DD(:,:,i)
3050 cd        write(iout,*) 'EE',EE(:,:,i)
3051 cd      enddo
3052 cd      call check_vecgrad
3053 cd      stop
3054       if (icheckgrad.eq.1) then
3055         do i=1,nres-1
3056           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3057           do k=1,3
3058             dc_norm(k,i)=dc(k,i)*fac
3059           enddo
3060 c          write (iout,*) 'i',i,' fac',fac
3061         enddo
3062       endif
3063       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3064      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3065      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3066 c        call vec_and_deriv
3067 #ifdef TIMING
3068         time01=MPI_Wtime()
3069 #endif
3070         call set_matrices
3071 #ifdef TIMING
3072         time_mat=time_mat+MPI_Wtime()-time01
3073 #endif
3074       endif
3075 cd      do i=1,nres-1
3076 cd        write (iout,*) 'i=',i
3077 cd        do k=1,3
3078 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3079 cd        enddo
3080 cd        do k=1,3
3081 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3082 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3083 cd        enddo
3084 cd      enddo
3085       t_eelecij=0.0d0
3086       ees=0.0D0
3087       evdw1=0.0D0
3088       eel_loc=0.0d0
3089       eello_turn3=0.0d0
3090       eello_turn4=0.0d0
3091       ind=0
3092       do i=1,nres
3093         num_cont_hb(i)=0
3094       enddo
3095 cd      print '(a)','Enter EELEC'
3096 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3097       do i=1,nres
3098         gel_loc_loc(i)=0.0d0
3099         gcorr_loc(i)=0.0d0
3100       enddo
3101 c
3102 c
3103 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3104 C
3105 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3106 C
3107       do i=iturn3_start,iturn3_end
3108         dxi=dc(1,i)
3109         dyi=dc(2,i)
3110         dzi=dc(3,i)
3111         dx_normi=dc_norm(1,i)
3112         dy_normi=dc_norm(2,i)
3113         dz_normi=dc_norm(3,i)
3114         xmedi=c(1,i)+0.5d0*dxi
3115         ymedi=c(2,i)+0.5d0*dyi
3116         zmedi=c(3,i)+0.5d0*dzi
3117         num_conti=0
3118         call eelecij(i,i+2,ees,evdw1,eel_loc)
3119         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3120         num_cont_hb(i)=num_conti
3121       enddo
3122       do i=iturn4_start,iturn4_end
3123         dxi=dc(1,i)
3124         dyi=dc(2,i)
3125         dzi=dc(3,i)
3126         dx_normi=dc_norm(1,i)
3127         dy_normi=dc_norm(2,i)
3128         dz_normi=dc_norm(3,i)
3129         xmedi=c(1,i)+0.5d0*dxi
3130         ymedi=c(2,i)+0.5d0*dyi
3131         zmedi=c(3,i)+0.5d0*dzi
3132         num_conti=num_cont_hb(i)
3133         call eelecij(i,i+3,ees,evdw1,eel_loc)
3134         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3135         num_cont_hb(i)=num_conti
3136       enddo   ! i
3137 c
3138 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3139 c
3140       do i=iatel_s,iatel_e
3141         dxi=dc(1,i)
3142         dyi=dc(2,i)
3143         dzi=dc(3,i)
3144         dx_normi=dc_norm(1,i)
3145         dy_normi=dc_norm(2,i)
3146         dz_normi=dc_norm(3,i)
3147         xmedi=c(1,i)+0.5d0*dxi
3148         ymedi=c(2,i)+0.5d0*dyi
3149         zmedi=c(3,i)+0.5d0*dzi
3150 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3151         num_conti=num_cont_hb(i)
3152         do j=ielstart(i),ielend(i)
3153           call eelecij(i,j,ees,evdw1,eel_loc)
3154         enddo ! j
3155         num_cont_hb(i)=num_conti
3156       enddo   ! i
3157 c      write (iout,*) "Number of loop steps in EELEC:",ind
3158 cd      do i=1,nres
3159 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3160 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3161 cd      enddo
3162 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3163 ccc      eel_loc=eel_loc+eello_turn3
3164 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3165       return
3166       end
3167 C-------------------------------------------------------------------------------
3168       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3169       implicit real*8 (a-h,o-z)
3170       include 'DIMENSIONS'
3171 #ifdef MPI
3172       include "mpif.h"
3173 #endif
3174       include 'COMMON.CONTROL'
3175       include 'COMMON.IOUNITS'
3176       include 'COMMON.GEO'
3177       include 'COMMON.VAR'
3178       include 'COMMON.LOCAL'
3179       include 'COMMON.CHAIN'
3180       include 'COMMON.DERIV'
3181       include 'COMMON.INTERACT'
3182       include 'COMMON.CONTACTS'
3183       include 'COMMON.TORSION'
3184       include 'COMMON.VECTORS'
3185       include 'COMMON.FFIELD'
3186       include 'COMMON.TIME1'
3187       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3188      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3189       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3190      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3191       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3192      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3193      &    num_conti,j1,j2
3194 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3195 #ifdef MOMENT
3196       double precision scal_el /1.0d0/
3197 #else
3198       double precision scal_el /0.5d0/
3199 #endif
3200 C 12/13/98
3201 C 13-go grudnia roku pamietnego...
3202       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3203      &                   0.0d0,1.0d0,0.0d0,
3204      &                   0.0d0,0.0d0,1.0d0/
3205 c          time00=MPI_Wtime()
3206 cd      write (iout,*) "eelecij",i,j
3207 c          ind=ind+1
3208           iteli=itel(i)
3209           itelj=itel(j)
3210           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3211           aaa=app(iteli,itelj)
3212           bbb=bpp(iteli,itelj)
3213           ael6i=ael6(iteli,itelj)
3214           ael3i=ael3(iteli,itelj)
3215           dxj=dc(1,j)
3216           dyj=dc(2,j)
3217           dzj=dc(3,j)
3218           dx_normj=dc_norm(1,j)
3219           dy_normj=dc_norm(2,j)
3220           dz_normj=dc_norm(3,j)
3221           xj=c(1,j)+0.5D0*dxj-xmedi
3222           yj=c(2,j)+0.5D0*dyj-ymedi
3223           zj=c(3,j)+0.5D0*dzj-zmedi
3224           rij=xj*xj+yj*yj+zj*zj
3225           rrmij=1.0D0/rij
3226           rij=dsqrt(rij)
3227           rmij=1.0D0/rij
3228           r3ij=rrmij*rmij
3229           r6ij=r3ij*r3ij
3230           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3231           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3232           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3233           fac=cosa-3.0D0*cosb*cosg
3234           ev1=aaa*r6ij*r6ij
3235 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3236           if (j.eq.i+2) ev1=scal_el*ev1
3237           ev2=bbb*r6ij
3238           fac3=ael6i*r6ij
3239           fac4=ael3i*r3ij
3240           evdwij=ev1+ev2
3241           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3242           el2=fac4*fac
3243           eesij=el1+el2
3244 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3245           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3246           ees=ees+eesij
3247           evdw1=evdw1+evdwij
3248 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3249 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3250 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3251 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3252
3253           if (energy_dec) then
3254               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3255               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3256           endif
3257
3258 C
3259 C Calculate contributions to the Cartesian gradient.
3260 C
3261 #ifdef SPLITELE
3262           facvdw=-6*rrmij*(ev1+evdwij)
3263           facel=-3*rrmij*(el1+eesij)
3264           fac1=fac
3265           erij(1)=xj*rmij
3266           erij(2)=yj*rmij
3267           erij(3)=zj*rmij
3268 *
3269 * Radial derivatives. First process both termini of the fragment (i,j)
3270 *
3271           ggg(1)=facel*xj
3272           ggg(2)=facel*yj
3273           ggg(3)=facel*zj
3274 c          do k=1,3
3275 c            ghalf=0.5D0*ggg(k)
3276 c            gelc(k,i)=gelc(k,i)+ghalf
3277 c            gelc(k,j)=gelc(k,j)+ghalf
3278 c          enddo
3279 c 9/28/08 AL Gradient compotents will be summed only at the end
3280           do k=1,3
3281             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3282             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3283           enddo
3284 *
3285 * Loop over residues i+1 thru j-1.
3286 *
3287 cgrad          do k=i+1,j-1
3288 cgrad            do l=1,3
3289 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3290 cgrad            enddo
3291 cgrad          enddo
3292           ggg(1)=facvdw*xj
3293           ggg(2)=facvdw*yj
3294           ggg(3)=facvdw*zj
3295 c          do k=1,3
3296 c            ghalf=0.5D0*ggg(k)
3297 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3298 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3299 c          enddo
3300 c 9/28/08 AL Gradient compotents will be summed only at the end
3301           do k=1,3
3302             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3303             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3304           enddo
3305 *
3306 * Loop over residues i+1 thru j-1.
3307 *
3308 cgrad          do k=i+1,j-1
3309 cgrad            do l=1,3
3310 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3311 cgrad            enddo
3312 cgrad          enddo
3313 #else
3314           facvdw=ev1+evdwij
3315           facel=el1+eesij
3316           fac1=fac
3317           fac=-3*rrmij*(facvdw+facvdw+facel)
3318           erij(1)=xj*rmij
3319           erij(2)=yj*rmij
3320           erij(3)=zj*rmij
3321 *
3322 * Radial derivatives. First process both termini of the fragment (i,j)
3323 *
3324           ggg(1)=fac*xj
3325           ggg(2)=fac*yj
3326           ggg(3)=fac*zj
3327 c          do k=1,3
3328 c            ghalf=0.5D0*ggg(k)
3329 c            gelc(k,i)=gelc(k,i)+ghalf
3330 c            gelc(k,j)=gelc(k,j)+ghalf
3331 c          enddo
3332 c 9/28/08 AL Gradient compotents will be summed only at the end
3333           do k=1,3
3334             gelc_long(k,j)=gelc(k,j)+ggg(k)
3335             gelc_long(k,i)=gelc(k,i)-ggg(k)
3336           enddo
3337 *
3338 * Loop over residues i+1 thru j-1.
3339 *
3340 cgrad          do k=i+1,j-1
3341 cgrad            do l=1,3
3342 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3343 cgrad            enddo
3344 cgrad          enddo
3345 c 9/28/08 AL Gradient compotents will be summed only at the end
3346           ggg(1)=facvdw*xj
3347           ggg(2)=facvdw*yj
3348           ggg(3)=facvdw*zj
3349           do k=1,3
3350             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3351             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3352           enddo
3353 #endif
3354 *
3355 * Angular part
3356 *
3357           ecosa=2.0D0*fac3*fac1+fac4
3358           fac4=-3.0D0*fac4
3359           fac3=-6.0D0*fac3
3360           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3361           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3362           do k=1,3
3363             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3364             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3365           enddo
3366 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3367 cd   &          (dcosg(k),k=1,3)
3368           do k=1,3
3369             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3370           enddo
3371 c          do k=1,3
3372 c            ghalf=0.5D0*ggg(k)
3373 c            gelc(k,i)=gelc(k,i)+ghalf
3374 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3375 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3376 c            gelc(k,j)=gelc(k,j)+ghalf
3377 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3378 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3379 c          enddo
3380 cgrad          do k=i+1,j-1
3381 cgrad            do l=1,3
3382 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3383 cgrad            enddo
3384 cgrad          enddo
3385           do k=1,3
3386             gelc(k,i)=gelc(k,i)
3387      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3388      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3389             gelc(k,j)=gelc(k,j)
3390      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3391      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3392             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3393             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3394           enddo
3395           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3396      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3397      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3398 C
3399 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3400 C   energy of a peptide unit is assumed in the form of a second-order
3401 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3402 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3403 C   are computed for EVERY pair of non-contiguous peptide groups.
3404 C
3405           if (j.lt.nres-1) then
3406             j1=j+1
3407             j2=j-1
3408           else
3409             j1=j-1
3410             j2=j-2
3411           endif
3412           kkk=0
3413           do k=1,2
3414             do l=1,2
3415               kkk=kkk+1
3416               muij(kkk)=mu(k,i)*mu(l,j)
3417             enddo
3418           enddo
3419 cd         write (iout,*) 'EELEC: i',i,' j',j
3420 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3421 cd          write(iout,*) 'muij',muij
3422           ury=scalar(uy(1,i),erij)
3423           urz=scalar(uz(1,i),erij)
3424           vry=scalar(uy(1,j),erij)
3425           vrz=scalar(uz(1,j),erij)
3426           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3427           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3428           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3429           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3430           fac=dsqrt(-ael6i)*r3ij
3431           a22=a22*fac
3432           a23=a23*fac
3433           a32=a32*fac
3434           a33=a33*fac
3435 cd          write (iout,'(4i5,4f10.5)')
3436 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3437 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3438 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3439 cd     &      uy(:,j),uz(:,j)
3440 cd          write (iout,'(4f10.5)')
3441 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3442 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3443 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3444 cd           write (iout,'(9f10.5/)')
3445 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3446 C Derivatives of the elements of A in virtual-bond vectors
3447           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3448           do k=1,3
3449             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3450             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3451             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3452             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3453             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3454             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3455             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3456             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3457             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3458             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3459             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3460             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3461           enddo
3462 C Compute radial contributions to the gradient
3463           facr=-3.0d0*rrmij
3464           a22der=a22*facr
3465           a23der=a23*facr
3466           a32der=a32*facr
3467           a33der=a33*facr
3468           agg(1,1)=a22der*xj
3469           agg(2,1)=a22der*yj
3470           agg(3,1)=a22der*zj
3471           agg(1,2)=a23der*xj
3472           agg(2,2)=a23der*yj
3473           agg(3,2)=a23der*zj
3474           agg(1,3)=a32der*xj
3475           agg(2,3)=a32der*yj
3476           agg(3,3)=a32der*zj
3477           agg(1,4)=a33der*xj
3478           agg(2,4)=a33der*yj
3479           agg(3,4)=a33der*zj
3480 C Add the contributions coming from er
3481           fac3=-3.0d0*fac
3482           do k=1,3
3483             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3484             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3485             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3486             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3487           enddo
3488           do k=1,3
3489 C Derivatives in DC(i)
3490 cgrad            ghalf1=0.5d0*agg(k,1)
3491 cgrad            ghalf2=0.5d0*agg(k,2)
3492 cgrad            ghalf3=0.5d0*agg(k,3)
3493 cgrad            ghalf4=0.5d0*agg(k,4)
3494             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3495      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3496             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3497      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3498             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3499      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3500             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3501      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3502 C Derivatives in DC(i+1)
3503             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3504      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3505             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3506      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3507             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3508      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3509             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3510      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3511 C Derivatives in DC(j)
3512             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3513      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3514             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3515      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3516             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3517      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3518             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3519      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3520 C Derivatives in DC(j+1) or DC(nres-1)
3521             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3522      &      -3.0d0*vryg(k,3)*ury)
3523             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3524      &      -3.0d0*vrzg(k,3)*ury)
3525             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3526      &      -3.0d0*vryg(k,3)*urz)
3527             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3528      &      -3.0d0*vrzg(k,3)*urz)
3529 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3530 cgrad              do l=1,4
3531 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3532 cgrad              enddo
3533 cgrad            endif
3534           enddo
3535           acipa(1,1)=a22
3536           acipa(1,2)=a23
3537           acipa(2,1)=a32
3538           acipa(2,2)=a33
3539           a22=-a22
3540           a23=-a23
3541           do l=1,2
3542             do k=1,3
3543               agg(k,l)=-agg(k,l)
3544               aggi(k,l)=-aggi(k,l)
3545               aggi1(k,l)=-aggi1(k,l)
3546               aggj(k,l)=-aggj(k,l)
3547               aggj1(k,l)=-aggj1(k,l)
3548             enddo
3549           enddo
3550           if (j.lt.nres-1) then
3551             a22=-a22
3552             a32=-a32
3553             do l=1,3,2
3554               do k=1,3
3555                 agg(k,l)=-agg(k,l)
3556                 aggi(k,l)=-aggi(k,l)
3557                 aggi1(k,l)=-aggi1(k,l)
3558                 aggj(k,l)=-aggj(k,l)
3559                 aggj1(k,l)=-aggj1(k,l)
3560               enddo
3561             enddo
3562           else
3563             a22=-a22
3564             a23=-a23
3565             a32=-a32
3566             a33=-a33
3567             do l=1,4
3568               do k=1,3
3569                 agg(k,l)=-agg(k,l)
3570                 aggi(k,l)=-aggi(k,l)
3571                 aggi1(k,l)=-aggi1(k,l)
3572                 aggj(k,l)=-aggj(k,l)
3573                 aggj1(k,l)=-aggj1(k,l)
3574               enddo
3575             enddo
3576           endif
3577           ENDIF ! WCORR
3578           IF (wel_loc.gt.0.0d0) THEN
3579 C Contribution to the local-electrostatic energy coming from the i-j pair
3580           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3581      &     +a33*muij(4)
3582 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3583
3584           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3585      &            'eelloc',i,j,eel_loc_ij
3586
3587           eel_loc=eel_loc+eel_loc_ij
3588 C Partial derivatives in virtual-bond dihedral angles gamma
3589           if (i.gt.1)
3590      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3591      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3592      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3593           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3594      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3595      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3596 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3597           do l=1,3
3598             ggg(l)=agg(l,1)*muij(1)+
3599      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3600             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3601             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3602 cgrad            ghalf=0.5d0*ggg(l)
3603 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3604 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3605           enddo
3606 cgrad          do k=i+1,j2
3607 cgrad            do l=1,3
3608 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3609 cgrad            enddo
3610 cgrad          enddo
3611 C Remaining derivatives of eello
3612           do l=1,3
3613             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3614      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3615             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3616      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3617             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3618      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3619             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3620      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3621           enddo
3622           ENDIF
3623 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3624 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3625           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3626      &       .and. num_conti.le.maxconts) then
3627 c            write (iout,*) i,j," entered corr"
3628 C
3629 C Calculate the contact function. The ith column of the array JCONT will
3630 C contain the numbers of atoms that make contacts with the atom I (of numbers
3631 C greater than I). The arrays FACONT and GACONT will contain the values of
3632 C the contact function and its derivative.
3633 c           r0ij=1.02D0*rpp(iteli,itelj)
3634 c           r0ij=1.11D0*rpp(iteli,itelj)
3635             r0ij=2.20D0*rpp(iteli,itelj)
3636 c           r0ij=1.55D0*rpp(iteli,itelj)
3637             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3638             if (fcont.gt.0.0D0) then
3639               num_conti=num_conti+1
3640               if (num_conti.gt.maxconts) then
3641                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3642      &                         ' will skip next contacts for this conf.'
3643               else
3644                 jcont_hb(num_conti,i)=j
3645 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3646 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3647                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3648      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3649 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3650 C  terms.
3651                 d_cont(num_conti,i)=rij
3652 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3653 C     --- Electrostatic-interaction matrix ---
3654                 a_chuj(1,1,num_conti,i)=a22
3655                 a_chuj(1,2,num_conti,i)=a23
3656                 a_chuj(2,1,num_conti,i)=a32
3657                 a_chuj(2,2,num_conti,i)=a33
3658 C     --- Gradient of rij
3659                 do kkk=1,3
3660                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3661                 enddo
3662                 kkll=0
3663                 do k=1,2
3664                   do l=1,2
3665                     kkll=kkll+1
3666                     do m=1,3
3667                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3668                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3669                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3670                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3671                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3672                     enddo
3673                   enddo
3674                 enddo
3675                 ENDIF
3676                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3677 C Calculate contact energies
3678                 cosa4=4.0D0*cosa
3679                 wij=cosa-3.0D0*cosb*cosg
3680                 cosbg1=cosb+cosg
3681                 cosbg2=cosb-cosg
3682 c               fac3=dsqrt(-ael6i)/r0ij**3
3683                 fac3=dsqrt(-ael6i)*r3ij
3684 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3685                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3686                 if (ees0tmp.gt.0) then
3687                   ees0pij=dsqrt(ees0tmp)
3688                 else
3689                   ees0pij=0
3690                 endif
3691 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3692                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3693                 if (ees0tmp.gt.0) then
3694                   ees0mij=dsqrt(ees0tmp)
3695                 else
3696                   ees0mij=0
3697                 endif
3698 c               ees0mij=0.0D0
3699                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3700                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3701 C Diagnostics. Comment out or remove after debugging!
3702 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3703 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3704 c               ees0m(num_conti,i)=0.0D0
3705 C End diagnostics.
3706 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3707 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3708 C Angular derivatives of the contact function
3709                 ees0pij1=fac3/ees0pij
3710                 ees0mij1=fac3/ees0mij
3711                 fac3p=-3.0D0*fac3*rrmij
3712                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3713                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3714 c               ees0mij1=0.0D0
3715                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3716                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3717                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3718                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3719                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3720                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3721                 ecosap=ecosa1+ecosa2
3722                 ecosbp=ecosb1+ecosb2
3723                 ecosgp=ecosg1+ecosg2
3724                 ecosam=ecosa1-ecosa2
3725                 ecosbm=ecosb1-ecosb2
3726                 ecosgm=ecosg1-ecosg2
3727 C Diagnostics
3728 c               ecosap=ecosa1
3729 c               ecosbp=ecosb1
3730 c               ecosgp=ecosg1
3731 c               ecosam=0.0D0
3732 c               ecosbm=0.0D0
3733 c               ecosgm=0.0D0
3734 C End diagnostics
3735                 facont_hb(num_conti,i)=fcont
3736                 fprimcont=fprimcont/rij
3737 cd              facont_hb(num_conti,i)=1.0D0
3738 C Following line is for diagnostics.
3739 cd              fprimcont=0.0D0
3740                 do k=1,3
3741                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3742                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3743                 enddo
3744                 do k=1,3
3745                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3746                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3747                 enddo
3748                 gggp(1)=gggp(1)+ees0pijp*xj
3749                 gggp(2)=gggp(2)+ees0pijp*yj
3750                 gggp(3)=gggp(3)+ees0pijp*zj
3751                 gggm(1)=gggm(1)+ees0mijp*xj
3752                 gggm(2)=gggm(2)+ees0mijp*yj
3753                 gggm(3)=gggm(3)+ees0mijp*zj
3754 C Derivatives due to the contact function
3755                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3756                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3757                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3758                 do k=1,3
3759 c
3760 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3761 c          following the change of gradient-summation algorithm.
3762 c
3763 cgrad                  ghalfp=0.5D0*gggp(k)
3764 cgrad                  ghalfm=0.5D0*gggm(k)
3765                   gacontp_hb1(k,num_conti,i)=!ghalfp
3766      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3767      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3768                   gacontp_hb2(k,num_conti,i)=!ghalfp
3769      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3770      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3771                   gacontp_hb3(k,num_conti,i)=gggp(k)
3772                   gacontm_hb1(k,num_conti,i)=!ghalfm
3773      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3774      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3775                   gacontm_hb2(k,num_conti,i)=!ghalfm
3776      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3777      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3778                   gacontm_hb3(k,num_conti,i)=gggm(k)
3779                 enddo
3780 C Diagnostics. Comment out or remove after debugging!
3781 cdiag           do k=1,3
3782 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3783 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3784 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3785 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3786 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3787 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3788 cdiag           enddo
3789               ENDIF ! wcorr
3790               endif  ! num_conti.le.maxconts
3791             endif  ! fcont.gt.0
3792           endif    ! j.gt.i+1
3793           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3794             do k=1,4
3795               do l=1,3
3796                 ghalf=0.5d0*agg(l,k)
3797                 aggi(l,k)=aggi(l,k)+ghalf
3798                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3799                 aggj(l,k)=aggj(l,k)+ghalf
3800               enddo
3801             enddo
3802             if (j.eq.nres-1 .and. i.lt.j-2) then
3803               do k=1,4
3804                 do l=1,3
3805                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3806                 enddo
3807               enddo
3808             endif
3809           endif
3810 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3811       return
3812       end
3813 C-----------------------------------------------------------------------------
3814       subroutine eturn3(i,eello_turn3)
3815 C Third- and fourth-order contributions from turns
3816       implicit real*8 (a-h,o-z)
3817       include 'DIMENSIONS'
3818       include 'COMMON.IOUNITS'
3819       include 'COMMON.GEO'
3820       include 'COMMON.VAR'
3821       include 'COMMON.LOCAL'
3822       include 'COMMON.CHAIN'
3823       include 'COMMON.DERIV'
3824       include 'COMMON.INTERACT'
3825       include 'COMMON.CONTACTS'
3826       include 'COMMON.TORSION'
3827       include 'COMMON.VECTORS'
3828       include 'COMMON.FFIELD'
3829       include 'COMMON.CONTROL'
3830       dimension ggg(3)
3831       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3832      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3833      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3834       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3835      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3836       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3837      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3838      &    num_conti,j1,j2
3839       j=i+2
3840 c      write (iout,*) "eturn3",i,j,j1,j2
3841       a_temp(1,1)=a22
3842       a_temp(1,2)=a23
3843       a_temp(2,1)=a32
3844       a_temp(2,2)=a33
3845 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3846 C
3847 C               Third-order contributions
3848 C
3849 C                 (i+2)o----(i+3)
3850 C                      | |
3851 C                      | |
3852 C                 (i+1)o----i
3853 C
3854 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3855 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3856         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3857         call transpose2(auxmat(1,1),auxmat1(1,1))
3858         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3859         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3860         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3861      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3862 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3863 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3864 cd     &    ' eello_turn3_num',4*eello_turn3_num
3865 C Derivatives in gamma(i)
3866         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3867         call transpose2(auxmat2(1,1),auxmat3(1,1))
3868         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3869         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3870 C Derivatives in gamma(i+1)
3871         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3872         call transpose2(auxmat2(1,1),auxmat3(1,1))
3873         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3874         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3875      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3876 C Cartesian derivatives
3877         do l=1,3
3878 c            ghalf1=0.5d0*agg(l,1)
3879 c            ghalf2=0.5d0*agg(l,2)
3880 c            ghalf3=0.5d0*agg(l,3)
3881 c            ghalf4=0.5d0*agg(l,4)
3882           a_temp(1,1)=aggi(l,1)!+ghalf1
3883           a_temp(1,2)=aggi(l,2)!+ghalf2
3884           a_temp(2,1)=aggi(l,3)!+ghalf3
3885           a_temp(2,2)=aggi(l,4)!+ghalf4
3886           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3887           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3888      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3889           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3890           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3891           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3892           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3893           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3894           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3895      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3896           a_temp(1,1)=aggj(l,1)!+ghalf1
3897           a_temp(1,2)=aggj(l,2)!+ghalf2
3898           a_temp(2,1)=aggj(l,3)!+ghalf3
3899           a_temp(2,2)=aggj(l,4)!+ghalf4
3900           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3901           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3902      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3903           a_temp(1,1)=aggj1(l,1)
3904           a_temp(1,2)=aggj1(l,2)
3905           a_temp(2,1)=aggj1(l,3)
3906           a_temp(2,2)=aggj1(l,4)
3907           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3908           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3909      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3910         enddo
3911       return
3912       end
3913 C-------------------------------------------------------------------------------
3914       subroutine eturn4(i,eello_turn4)
3915 C Third- and fourth-order contributions from turns
3916       implicit real*8 (a-h,o-z)
3917       include 'DIMENSIONS'
3918       include 'COMMON.IOUNITS'
3919       include 'COMMON.GEO'
3920       include 'COMMON.VAR'
3921       include 'COMMON.LOCAL'
3922       include 'COMMON.CHAIN'
3923       include 'COMMON.DERIV'
3924       include 'COMMON.INTERACT'
3925       include 'COMMON.CONTACTS'
3926       include 'COMMON.TORSION'
3927       include 'COMMON.VECTORS'
3928       include 'COMMON.FFIELD'
3929       include 'COMMON.CONTROL'
3930       dimension ggg(3)
3931       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3932      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3933      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3934       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3935      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3936       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3937      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3938      &    num_conti,j1,j2
3939       j=i+3
3940 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3941 C
3942 C               Fourth-order contributions
3943 C
3944 C                 (i+3)o----(i+4)
3945 C                     /  |
3946 C               (i+2)o   |
3947 C                     \  |
3948 C                 (i+1)o----i
3949 C
3950 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3951 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3952 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3953         a_temp(1,1)=a22
3954         a_temp(1,2)=a23
3955         a_temp(2,1)=a32
3956         a_temp(2,2)=a33
3957         iti1=itortyp(itype(i+1))
3958         iti2=itortyp(itype(i+2))
3959         iti3=itortyp(itype(i+3))
3960 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3961         call transpose2(EUg(1,1,i+1),e1t(1,1))
3962         call transpose2(Eug(1,1,i+2),e2t(1,1))
3963         call transpose2(Eug(1,1,i+3),e3t(1,1))
3964         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3965         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3966         s1=scalar2(b1(1,iti2),auxvec(1))
3967         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3968         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3969         s2=scalar2(b1(1,iti1),auxvec(1))
3970         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3971         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3972         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3973         eello_turn4=eello_turn4-(s1+s2+s3)
3974         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3975      &      'eturn4',i,j,-(s1+s2+s3)
3976 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3977 cd     &    ' eello_turn4_num',8*eello_turn4_num
3978 C Derivatives in gamma(i)
3979         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3980         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3981         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3982         s1=scalar2(b1(1,iti2),auxvec(1))
3983         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3984         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3985         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3986 C Derivatives in gamma(i+1)
3987         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3988         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3989         s2=scalar2(b1(1,iti1),auxvec(1))
3990         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3991         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3992         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3993         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3994 C Derivatives in gamma(i+2)
3995         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3996         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3997         s1=scalar2(b1(1,iti2),auxvec(1))
3998         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3999         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4000         s2=scalar2(b1(1,iti1),auxvec(1))
4001         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4002         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4003         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4004         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
4005 C Cartesian derivatives
4006 C Derivatives of this turn contributions in DC(i+2)
4007         if (j.lt.nres-1) then
4008           do l=1,3
4009             a_temp(1,1)=agg(l,1)
4010             a_temp(1,2)=agg(l,2)
4011             a_temp(2,1)=agg(l,3)
4012             a_temp(2,2)=agg(l,4)
4013             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4014             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4015             s1=scalar2(b1(1,iti2),auxvec(1))
4016             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4017             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4018             s2=scalar2(b1(1,iti1),auxvec(1))
4019             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4020             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4021             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4022             ggg(l)=-(s1+s2+s3)
4023             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
4024           enddo
4025         endif
4026 C Remaining derivatives of this turn contribution
4027         do l=1,3
4028           a_temp(1,1)=aggi(l,1)
4029           a_temp(1,2)=aggi(l,2)
4030           a_temp(2,1)=aggi(l,3)
4031           a_temp(2,2)=aggi(l,4)
4032           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4033           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4034           s1=scalar2(b1(1,iti2),auxvec(1))
4035           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4036           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4037           s2=scalar2(b1(1,iti1),auxvec(1))
4038           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4039           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4040           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4041           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
4042           a_temp(1,1)=aggi1(l,1)
4043           a_temp(1,2)=aggi1(l,2)
4044           a_temp(2,1)=aggi1(l,3)
4045           a_temp(2,2)=aggi1(l,4)
4046           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4047           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4048           s1=scalar2(b1(1,iti2),auxvec(1))
4049           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4050           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4051           s2=scalar2(b1(1,iti1),auxvec(1))
4052           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4053           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4054           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4055           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
4056           a_temp(1,1)=aggj(l,1)
4057           a_temp(1,2)=aggj(l,2)
4058           a_temp(2,1)=aggj(l,3)
4059           a_temp(2,2)=aggj(l,4)
4060           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4061           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4062           s1=scalar2(b1(1,iti2),auxvec(1))
4063           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4064           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4065           s2=scalar2(b1(1,iti1),auxvec(1))
4066           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4067           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4068           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4069           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4070           a_temp(1,1)=aggj1(l,1)
4071           a_temp(1,2)=aggj1(l,2)
4072           a_temp(2,1)=aggj1(l,3)
4073           a_temp(2,2)=aggj1(l,4)
4074           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4075           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4076           s1=scalar2(b1(1,iti2),auxvec(1))
4077           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4078           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4079           s2=scalar2(b1(1,iti1),auxvec(1))
4080           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4081           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4082           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4083 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4084           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4085         enddo
4086       return
4087       end
4088 C-----------------------------------------------------------------------------
4089       subroutine vecpr(u,v,w)
4090       implicit real*8(a-h,o-z)
4091       dimension u(3),v(3),w(3)
4092       w(1)=u(2)*v(3)-u(3)*v(2)
4093       w(2)=-u(1)*v(3)+u(3)*v(1)
4094       w(3)=u(1)*v(2)-u(2)*v(1)
4095       return
4096       end
4097 C-----------------------------------------------------------------------------
4098       subroutine unormderiv(u,ugrad,unorm,ungrad)
4099 C This subroutine computes the derivatives of a normalized vector u, given
4100 C the derivatives computed without normalization conditions, ugrad. Returns
4101 C ungrad.
4102       implicit none
4103       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4104       double precision vec(3)
4105       double precision scalar
4106       integer i,j
4107 c      write (2,*) 'ugrad',ugrad
4108 c      write (2,*) 'u',u
4109       do i=1,3
4110         vec(i)=scalar(ugrad(1,i),u(1))
4111       enddo
4112 c      write (2,*) 'vec',vec
4113       do i=1,3
4114         do j=1,3
4115           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4116         enddo
4117       enddo
4118 c      write (2,*) 'ungrad',ungrad
4119       return
4120       end
4121 C-----------------------------------------------------------------------------
4122       subroutine escp_soft_sphere(evdw2,evdw2_14)
4123 C
4124 C This subroutine calculates the excluded-volume interaction energy between
4125 C peptide-group centers and side chains and its gradient in virtual-bond and
4126 C side-chain vectors.
4127 C
4128       implicit real*8 (a-h,o-z)
4129       include 'DIMENSIONS'
4130       include 'COMMON.GEO'
4131       include 'COMMON.VAR'
4132       include 'COMMON.LOCAL'
4133       include 'COMMON.CHAIN'
4134       include 'COMMON.DERIV'
4135       include 'COMMON.INTERACT'
4136       include 'COMMON.FFIELD'
4137       include 'COMMON.IOUNITS'
4138       include 'COMMON.CONTROL'
4139       dimension ggg(3)
4140       evdw2=0.0D0
4141       evdw2_14=0.0d0
4142       r0_scp=4.5d0
4143 cd    print '(a)','Enter ESCP'
4144 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4145       do i=iatscp_s,iatscp_e
4146         iteli=itel(i)
4147         xi=0.5D0*(c(1,i)+c(1,i+1))
4148         yi=0.5D0*(c(2,i)+c(2,i+1))
4149         zi=0.5D0*(c(3,i)+c(3,i+1))
4150
4151         do iint=1,nscp_gr(i)
4152
4153         do j=iscpstart(i,iint),iscpend(i,iint)
4154           itypj=itype(j)
4155 C Uncomment following three lines for SC-p interactions
4156 c         xj=c(1,nres+j)-xi
4157 c         yj=c(2,nres+j)-yi
4158 c         zj=c(3,nres+j)-zi
4159 C Uncomment following three lines for Ca-p interactions
4160           xj=c(1,j)-xi
4161           yj=c(2,j)-yi
4162           zj=c(3,j)-zi
4163           rij=xj*xj+yj*yj+zj*zj
4164           r0ij=r0_scp
4165           r0ijsq=r0ij*r0ij
4166           if (rij.lt.r0ijsq) then
4167             evdwij=0.25d0*(rij-r0ijsq)**2
4168             fac=rij-r0ijsq
4169           else
4170             evdwij=0.0d0
4171             fac=0.0d0
4172           endif
4173           evdw2=evdw2+evdwij
4174 C
4175 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4176 C
4177           ggg(1)=xj*fac
4178           ggg(2)=yj*fac
4179           ggg(3)=zj*fac
4180 cgrad          if (j.lt.i) then
4181 cd          write (iout,*) 'j<i'
4182 C Uncomment following three lines for SC-p interactions
4183 c           do k=1,3
4184 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4185 c           enddo
4186 cgrad          else
4187 cd          write (iout,*) 'j>i'
4188 cgrad            do k=1,3
4189 cgrad              ggg(k)=-ggg(k)
4190 C Uncomment following line for SC-p interactions
4191 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4192 cgrad            enddo
4193 cgrad          endif
4194 cgrad          do k=1,3
4195 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4196 cgrad          enddo
4197 cgrad          kstart=min0(i+1,j)
4198 cgrad          kend=max0(i-1,j-1)
4199 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4200 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4201 cgrad          do k=kstart,kend
4202 cgrad            do l=1,3
4203 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4204 cgrad            enddo
4205 cgrad          enddo
4206           do k=1,3
4207             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4208             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4209           enddo
4210         enddo
4211
4212         enddo ! iint
4213       enddo ! i
4214       return
4215       end
4216 C-----------------------------------------------------------------------------
4217       subroutine escp(evdw2,evdw2_14)
4218 C
4219 C This subroutine calculates the excluded-volume interaction energy between
4220 C peptide-group centers and side chains and its gradient in virtual-bond and
4221 C side-chain vectors.
4222 C
4223       implicit real*8 (a-h,o-z)
4224       include 'DIMENSIONS'
4225       include 'COMMON.GEO'
4226       include 'COMMON.VAR'
4227       include 'COMMON.LOCAL'
4228       include 'COMMON.CHAIN'
4229       include 'COMMON.DERIV'
4230       include 'COMMON.INTERACT'
4231       include 'COMMON.FFIELD'
4232       include 'COMMON.IOUNITS'
4233       include 'COMMON.CONTROL'
4234       dimension ggg(3)
4235       evdw2=0.0D0
4236       evdw2_14=0.0d0
4237 cd    print '(a)','Enter ESCP'
4238 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4239       do i=iatscp_s,iatscp_e
4240         iteli=itel(i)
4241         xi=0.5D0*(c(1,i)+c(1,i+1))
4242         yi=0.5D0*(c(2,i)+c(2,i+1))
4243         zi=0.5D0*(c(3,i)+c(3,i+1))
4244
4245         do iint=1,nscp_gr(i)
4246
4247         do j=iscpstart(i,iint),iscpend(i,iint)
4248           itypj=itype(j)
4249 C Uncomment following three lines for SC-p interactions
4250 c         xj=c(1,nres+j)-xi
4251 c         yj=c(2,nres+j)-yi
4252 c         zj=c(3,nres+j)-zi
4253 C Uncomment following three lines for Ca-p interactions
4254           xj=c(1,j)-xi
4255           yj=c(2,j)-yi
4256           zj=c(3,j)-zi
4257           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4258           fac=rrij**expon2
4259           e1=fac*fac*aad(itypj,iteli)
4260           e2=fac*bad(itypj,iteli)
4261           if (iabs(j-i) .le. 2) then
4262             e1=scal14*e1
4263             e2=scal14*e2
4264             evdw2_14=evdw2_14+e1+e2
4265           endif
4266           evdwij=e1+e2
4267           evdw2=evdw2+evdwij
4268           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4269      &        'evdw2',i,j,evdwij
4270 C
4271 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4272 C
4273           fac=-(evdwij+e1)*rrij
4274           ggg(1)=xj*fac
4275           ggg(2)=yj*fac
4276           ggg(3)=zj*fac
4277 cgrad          if (j.lt.i) then
4278 cd          write (iout,*) 'j<i'
4279 C Uncomment following three lines for SC-p interactions
4280 c           do k=1,3
4281 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4282 c           enddo
4283 cgrad          else
4284 cd          write (iout,*) 'j>i'
4285 cgrad            do k=1,3
4286 cgrad              ggg(k)=-ggg(k)
4287 C Uncomment following line for SC-p interactions
4288 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4289 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4290 cgrad            enddo
4291 cgrad          endif
4292 cgrad          do k=1,3
4293 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4294 cgrad          enddo
4295 cgrad          kstart=min0(i+1,j)
4296 cgrad          kend=max0(i-1,j-1)
4297 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4298 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4299 cgrad          do k=kstart,kend
4300 cgrad            do l=1,3
4301 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4302 cgrad            enddo
4303 cgrad          enddo
4304           do k=1,3
4305             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4306             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4307           enddo
4308         enddo
4309
4310         enddo ! iint
4311       enddo ! i
4312       do i=1,nct
4313         do j=1,3
4314           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4315           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4316           gradx_scp(j,i)=expon*gradx_scp(j,i)
4317         enddo
4318       enddo
4319 C******************************************************************************
4320 C
4321 C                              N O T E !!!
4322 C
4323 C To save time the factor EXPON has been extracted from ALL components
4324 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4325 C use!
4326 C
4327 C******************************************************************************
4328       return
4329       end
4330 C--------------------------------------------------------------------------
4331       subroutine edis(ehpb)
4332 C
4333 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4334 C
4335       implicit real*8 (a-h,o-z)
4336       include 'DIMENSIONS'
4337       include 'COMMON.SBRIDGE'
4338       include 'COMMON.CHAIN'
4339       include 'COMMON.DERIV'
4340       include 'COMMON.VAR'
4341       include 'COMMON.INTERACT'
4342       include 'COMMON.IOUNITS'
4343       dimension ggg(3)
4344       ehpb=0.0D0
4345 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4346 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4347       if (link_end.eq.0) return
4348       do i=link_start,link_end
4349 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4350 C CA-CA distance used in regularization of structure.
4351         ii=ihpb(i)
4352         jj=jhpb(i)
4353 C iii and jjj point to the residues for which the distance is assigned.
4354         if (ii.gt.nres) then
4355           iii=ii-nres
4356           jjj=jj-nres
4357         else
4358           iii=ii
4359           jjj=jj
4360         endif
4361 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4362 c     &    dhpb(i),dhpb1(i),forcon(i)
4363 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4364 C    distance and angle dependent SS bond potential.
4365 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4366 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4367         if (.not.dyn_ss .and. i.le.nss) then
4368 C 15/02/13 CC dynamic SSbond - additional check
4369          if (ii.gt.nres
4370      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4371           call ssbond_ene(iii,jjj,eij)
4372           ehpb=ehpb+2*eij
4373          endif
4374 cd          write (iout,*) "eij",eij
4375         else if (ii.gt.nres .and. jj.gt.nres) then
4376 c Restraints from contact prediction
4377           dd=dist(ii,jj)
4378           if (dhpb1(i).gt.0.0d0) then
4379             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4380             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4381 c            write (iout,*) "beta nmr",
4382 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4383           else
4384             dd=dist(ii,jj)
4385             rdis=dd-dhpb(i)
4386 C Get the force constant corresponding to this distance.
4387             waga=forcon(i)
4388 C Calculate the contribution to energy.
4389             ehpb=ehpb+waga*rdis*rdis
4390 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4391 C
4392 C Evaluate gradient.
4393 C
4394             fac=waga*rdis/dd
4395           endif
4396           do j=1,3
4397             ggg(j)=fac*(c(j,jj)-c(j,ii))
4398           enddo
4399           do j=1,3
4400             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4401             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4402           enddo
4403           do k=1,3
4404             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4405             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4406           enddo
4407         else
4408 C Calculate the distance between the two points and its difference from the
4409 C target distance.
4410           dd=dist(ii,jj)
4411           if (dhpb1(i).gt.0.0d0) then
4412             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4413             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4414 c            write (iout,*) "alph nmr",
4415 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4416           else
4417             rdis=dd-dhpb(i)
4418 C Get the force constant corresponding to this distance.
4419             waga=forcon(i)
4420 C Calculate the contribution to energy.
4421             ehpb=ehpb+waga*rdis*rdis
4422 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4423 C
4424 C Evaluate gradient.
4425 C
4426             fac=waga*rdis/dd
4427           endif
4428 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4429 cd   &   ' waga=',waga,' fac=',fac
4430             do j=1,3
4431               ggg(j)=fac*(c(j,jj)-c(j,ii))
4432             enddo
4433 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4434 C If this is a SC-SC distance, we need to calculate the contributions to the
4435 C Cartesian gradient in the SC vectors (ghpbx).
4436           if (iii.lt.ii) then
4437           do j=1,3
4438             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4439             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4440           enddo
4441           endif
4442 cgrad        do j=iii,jjj-1
4443 cgrad          do k=1,3
4444 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4445 cgrad          enddo
4446 cgrad        enddo
4447           do k=1,3
4448             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4449             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4450           enddo
4451         endif
4452       enddo
4453       ehpb=0.5D0*ehpb
4454       return
4455       end
4456 C--------------------------------------------------------------------------
4457       subroutine ssbond_ene(i,j,eij)
4458 C
4459 C Calculate the distance and angle dependent SS-bond potential energy
4460 C using a free-energy function derived based on RHF/6-31G** ab initio
4461 C calculations of diethyl disulfide.
4462 C
4463 C A. Liwo and U. Kozlowska, 11/24/03
4464 C
4465       implicit real*8 (a-h,o-z)
4466       include 'DIMENSIONS'
4467       include 'COMMON.SBRIDGE'
4468       include 'COMMON.CHAIN'
4469       include 'COMMON.DERIV'
4470       include 'COMMON.LOCAL'
4471       include 'COMMON.INTERACT'
4472       include 'COMMON.VAR'
4473       include 'COMMON.IOUNITS'
4474       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4475       itypi=itype(i)
4476       xi=c(1,nres+i)
4477       yi=c(2,nres+i)
4478       zi=c(3,nres+i)
4479       dxi=dc_norm(1,nres+i)
4480       dyi=dc_norm(2,nres+i)
4481       dzi=dc_norm(3,nres+i)
4482 c      dsci_inv=dsc_inv(itypi)
4483       dsci_inv=vbld_inv(nres+i)
4484       itypj=itype(j)
4485 c      dscj_inv=dsc_inv(itypj)
4486       dscj_inv=vbld_inv(nres+j)
4487       xj=c(1,nres+j)-xi
4488       yj=c(2,nres+j)-yi
4489       zj=c(3,nres+j)-zi
4490       dxj=dc_norm(1,nres+j)
4491       dyj=dc_norm(2,nres+j)
4492       dzj=dc_norm(3,nres+j)
4493       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4494       rij=dsqrt(rrij)
4495       erij(1)=xj*rij
4496       erij(2)=yj*rij
4497       erij(3)=zj*rij
4498       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4499       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4500       om12=dxi*dxj+dyi*dyj+dzi*dzj
4501       do k=1,3
4502         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4503         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4504       enddo
4505       rij=1.0d0/rij
4506       deltad=rij-d0cm
4507       deltat1=1.0d0-om1
4508       deltat2=1.0d0+om2
4509       deltat12=om2-om1+2.0d0
4510       cosphi=om12-om1*om2
4511       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4512      &  +akct*deltad*deltat12+ebr
4513      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4514 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4515 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4516 c     &  " deltat12",deltat12," eij",eij
4517       ed=2*akcm*deltad+akct*deltat12
4518       pom1=akct*deltad
4519       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4520       eom1=-2*akth*deltat1-pom1-om2*pom2
4521       eom2= 2*akth*deltat2+pom1-om1*pom2
4522       eom12=pom2
4523       do k=1,3
4524         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4525         ghpbx(k,i)=ghpbx(k,i)-ggk
4526      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4527      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4528         ghpbx(k,j)=ghpbx(k,j)+ggk
4529      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4530      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4531         ghpbc(k,i)=ghpbc(k,i)-ggk
4532         ghpbc(k,j)=ghpbc(k,j)+ggk
4533       enddo
4534 C
4535 C Calculate the components of the gradient in DC and X
4536 C
4537 cgrad      do k=i,j-1
4538 cgrad        do l=1,3
4539 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4540 cgrad        enddo
4541 cgrad      enddo
4542       return
4543       end
4544 C--------------------------------------------------------------------------
4545       subroutine ebond(estr)
4546 c
4547 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4548 c
4549       implicit real*8 (a-h,o-z)
4550       include 'DIMENSIONS'
4551       include 'COMMON.LOCAL'
4552       include 'COMMON.GEO'
4553       include 'COMMON.INTERACT'
4554       include 'COMMON.DERIV'
4555       include 'COMMON.VAR'
4556       include 'COMMON.CHAIN'
4557       include 'COMMON.IOUNITS'
4558       include 'COMMON.NAMES'
4559       include 'COMMON.FFIELD'
4560       include 'COMMON.CONTROL'
4561       include 'COMMON.SETUP'
4562       double precision u(3),ud(3)
4563       estr=0.0d0
4564       do i=ibondp_start,ibondp_end
4565         diff = vbld(i)-vbldp0
4566 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4567         estr=estr+diff*diff
4568         do j=1,3
4569           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4570         enddo
4571 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4572       enddo
4573       estr=0.5d0*AKP*estr
4574 c
4575 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4576 c
4577       do i=ibond_start,ibond_end
4578         iti=itype(i)
4579         if (iti.ne.10) then
4580           nbi=nbondterm(iti)
4581           if (nbi.eq.1) then
4582             diff=vbld(i+nres)-vbldsc0(1,iti)
4583 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4584 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4585             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4586             do j=1,3
4587               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4588             enddo
4589           else
4590             do j=1,nbi
4591               diff=vbld(i+nres)-vbldsc0(j,iti)
4592               ud(j)=aksc(j,iti)*diff
4593               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4594             enddo
4595             uprod=u(1)
4596             do j=2,nbi
4597               uprod=uprod*u(j)
4598             enddo
4599             usum=0.0d0
4600             usumsqder=0.0d0
4601             do j=1,nbi
4602               uprod1=1.0d0
4603               uprod2=1.0d0
4604               do k=1,nbi
4605                 if (k.ne.j) then
4606                   uprod1=uprod1*u(k)
4607                   uprod2=uprod2*u(k)*u(k)
4608                 endif
4609               enddo
4610               usum=usum+uprod1
4611               usumsqder=usumsqder+ud(j)*uprod2
4612             enddo
4613             estr=estr+uprod/usum
4614             do j=1,3
4615              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4616             enddo
4617           endif
4618         endif
4619       enddo
4620       return
4621       end
4622 #ifdef CRYST_THETA
4623 C--------------------------------------------------------------------------
4624       subroutine ebend(etheta)
4625 C
4626 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4627 C angles gamma and its derivatives in consecutive thetas and gammas.
4628 C
4629       implicit real*8 (a-h,o-z)
4630       include 'DIMENSIONS'
4631       include 'COMMON.LOCAL'
4632       include 'COMMON.GEO'
4633       include 'COMMON.INTERACT'
4634       include 'COMMON.DERIV'
4635       include 'COMMON.VAR'
4636       include 'COMMON.CHAIN'
4637       include 'COMMON.IOUNITS'
4638       include 'COMMON.NAMES'
4639       include 'COMMON.FFIELD'
4640       include 'COMMON.CONTROL'
4641       common /calcthet/ term1,term2,termm,diffak,ratak,
4642      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4643      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4644       double precision y(2),z(2)
4645       delta=0.02d0*pi
4646 c      time11=dexp(-2*time)
4647 c      time12=1.0d0
4648       etheta=0.0D0
4649 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4650       do i=ithet_start,ithet_end
4651 C Zero the energy function and its derivative at 0 or pi.
4652         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4653         it=itype(i-1)
4654         if (i.gt.3) then
4655 #ifdef OSF
4656           phii=phi(i)
4657           if (phii.ne.phii) phii=150.0
4658 #else
4659           phii=phi(i)
4660 #endif
4661           y(1)=dcos(phii)
4662           y(2)=dsin(phii)
4663         else
4664           y(1)=0.0D0
4665           y(2)=0.0D0
4666         endif
4667         if (i.lt.nres) then
4668 #ifdef OSF
4669           phii1=phi(i+1)
4670           if (phii1.ne.phii1) phii1=150.0
4671           phii1=pinorm(phii1)
4672           z(1)=cos(phii1)
4673 #else
4674           phii1=phi(i+1)
4675           z(1)=dcos(phii1)
4676 #endif
4677           z(2)=dsin(phii1)
4678         else
4679           z(1)=0.0D0
4680           z(2)=0.0D0
4681         endif
4682 C Calculate the "mean" value of theta from the part of the distribution
4683 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4684 C In following comments this theta will be referred to as t_c.
4685         thet_pred_mean=0.0d0
4686         do k=1,2
4687           athetk=athet(k,it)
4688           bthetk=bthet(k,it)
4689           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4690         enddo
4691         dthett=thet_pred_mean*ssd
4692         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4693 C Derivatives of the "mean" values in gamma1 and gamma2.
4694         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4695         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4696         if (theta(i).gt.pi-delta) then
4697           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4698      &         E_tc0)
4699           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4700           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4701           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4702      &        E_theta)
4703           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4704      &        E_tc)
4705         else if (theta(i).lt.delta) then
4706           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4707           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4708           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4709      &        E_theta)
4710           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4711           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4712      &        E_tc)
4713         else
4714           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4715      &        E_theta,E_tc)
4716         endif
4717         etheta=etheta+ethetai
4718         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4719      &      'ebend',i,ethetai
4720         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4721         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4722         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
4723       enddo
4724 C Ufff.... We've done all this!!!
4725       return
4726       end
4727 C---------------------------------------------------------------------------
4728       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4729      &     E_tc)
4730       implicit real*8 (a-h,o-z)
4731       include 'DIMENSIONS'
4732       include 'COMMON.LOCAL'
4733       include 'COMMON.IOUNITS'
4734       common /calcthet/ term1,term2,termm,diffak,ratak,
4735      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4736      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4737 C Calculate the contributions to both Gaussian lobes.
4738 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4739 C The "polynomial part" of the "standard deviation" of this part of
4740 C the distribution.
4741         sig=polthet(3,it)
4742         do j=2,0,-1
4743           sig=sig*thet_pred_mean+polthet(j,it)
4744         enddo
4745 C Derivative of the "interior part" of the "standard deviation of the"
4746 C gamma-dependent Gaussian lobe in t_c.
4747         sigtc=3*polthet(3,it)
4748         do j=2,1,-1
4749           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4750         enddo
4751         sigtc=sig*sigtc
4752 C Set the parameters of both Gaussian lobes of the distribution.
4753 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4754         fac=sig*sig+sigc0(it)
4755         sigcsq=fac+fac
4756         sigc=1.0D0/sigcsq
4757 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4758         sigsqtc=-4.0D0*sigcsq*sigtc
4759 c       print *,i,sig,sigtc,sigsqtc
4760 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4761         sigtc=-sigtc/(fac*fac)
4762 C Following variable is sigma(t_c)**(-2)
4763         sigcsq=sigcsq*sigcsq
4764         sig0i=sig0(it)
4765         sig0inv=1.0D0/sig0i**2
4766         delthec=thetai-thet_pred_mean
4767         delthe0=thetai-theta0i
4768         term1=-0.5D0*sigcsq*delthec*delthec
4769         term2=-0.5D0*sig0inv*delthe0*delthe0
4770 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4771 C NaNs in taking the logarithm. We extract the largest exponent which is added
4772 C to the energy (this being the log of the distribution) at the end of energy
4773 C term evaluation for this virtual-bond angle.
4774         if (term1.gt.term2) then
4775           termm=term1
4776           term2=dexp(term2-termm)
4777           term1=1.0d0
4778         else
4779           termm=term2
4780           term1=dexp(term1-termm)
4781           term2=1.0d0
4782         endif
4783 C The ratio between the gamma-independent and gamma-dependent lobes of
4784 C the distribution is a Gaussian function of thet_pred_mean too.
4785         diffak=gthet(2,it)-thet_pred_mean
4786         ratak=diffak/gthet(3,it)**2
4787         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4788 C Let's differentiate it in thet_pred_mean NOW.
4789         aktc=ak*ratak
4790 C Now put together the distribution terms to make complete distribution.
4791         termexp=term1+ak*term2
4792         termpre=sigc+ak*sig0i
4793 C Contribution of the bending energy from this theta is just the -log of
4794 C the sum of the contributions from the two lobes and the pre-exponential
4795 C factor. Simple enough, isn't it?
4796         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4797 C NOW the derivatives!!!
4798 C 6/6/97 Take into account the deformation.
4799         E_theta=(delthec*sigcsq*term1
4800      &       +ak*delthe0*sig0inv*term2)/termexp
4801         E_tc=((sigtc+aktc*sig0i)/termpre
4802      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4803      &       aktc*term2)/termexp)
4804       return
4805       end
4806 c-----------------------------------------------------------------------------
4807       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4808       implicit real*8 (a-h,o-z)
4809       include 'DIMENSIONS'
4810       include 'COMMON.LOCAL'
4811       include 'COMMON.IOUNITS'
4812       common /calcthet/ term1,term2,termm,diffak,ratak,
4813      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4814      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4815       delthec=thetai-thet_pred_mean
4816       delthe0=thetai-theta0i
4817 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4818       t3 = thetai-thet_pred_mean
4819       t6 = t3**2
4820       t9 = term1
4821       t12 = t3*sigcsq
4822       t14 = t12+t6*sigsqtc
4823       t16 = 1.0d0
4824       t21 = thetai-theta0i
4825       t23 = t21**2
4826       t26 = term2
4827       t27 = t21*t26
4828       t32 = termexp
4829       t40 = t32**2
4830       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4831      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4832      & *(-t12*t9-ak*sig0inv*t27)
4833       return
4834       end
4835 #else
4836 C--------------------------------------------------------------------------
4837       subroutine ebend(etheta)
4838 C
4839 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4840 C angles gamma and its derivatives in consecutive thetas and gammas.
4841 C ab initio-derived potentials from
4842 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4843 C
4844       implicit real*8 (a-h,o-z)
4845       include 'DIMENSIONS'
4846       include 'COMMON.LOCAL'
4847       include 'COMMON.GEO'
4848       include 'COMMON.INTERACT'
4849       include 'COMMON.DERIV'
4850       include 'COMMON.VAR'
4851       include 'COMMON.CHAIN'
4852       include 'COMMON.IOUNITS'
4853       include 'COMMON.NAMES'
4854       include 'COMMON.FFIELD'
4855       include 'COMMON.CONTROL'
4856       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4857      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4858      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4859      & sinph1ph2(maxdouble,maxdouble)
4860       logical lprn /.false./, lprn1 /.false./
4861       etheta=0.0D0
4862       do i=ithet_start,ithet_end
4863         dethetai=0.0d0
4864         dephii=0.0d0
4865         dephii1=0.0d0
4866         theti2=0.5d0*theta(i)
4867         ityp2=ithetyp(itype(i-1))
4868         do k=1,nntheterm
4869           coskt(k)=dcos(k*theti2)
4870           sinkt(k)=dsin(k*theti2)
4871         enddo
4872         if (i.gt.3) then
4873 #ifdef OSF
4874           phii=phi(i)
4875           if (phii.ne.phii) phii=150.0
4876 #else
4877           phii=phi(i)
4878 #endif
4879           ityp1=ithetyp(itype(i-2))
4880           do k=1,nsingle
4881             cosph1(k)=dcos(k*phii)
4882             sinph1(k)=dsin(k*phii)
4883           enddo
4884         else
4885           phii=0.0d0
4886           ityp1=nthetyp+1
4887           do k=1,nsingle
4888             cosph1(k)=0.0d0
4889             sinph1(k)=0.0d0
4890           enddo
4891         endif
4892         if (i.lt.nres) then
4893 #ifdef OSF
4894           phii1=phi(i+1)
4895           if (phii1.ne.phii1) phii1=150.0
4896           phii1=pinorm(phii1)
4897 #else
4898           phii1=phi(i+1)
4899 #endif
4900           ityp3=ithetyp(itype(i))
4901           do k=1,nsingle
4902             cosph2(k)=dcos(k*phii1)
4903             sinph2(k)=dsin(k*phii1)
4904           enddo
4905         else
4906           phii1=0.0d0
4907           ityp3=nthetyp+1
4908           do k=1,nsingle
4909             cosph2(k)=0.0d0
4910             sinph2(k)=0.0d0
4911           enddo
4912         endif
4913         ethetai=aa0thet(ityp1,ityp2,ityp3)
4914         do k=1,ndouble
4915           do l=1,k-1
4916             ccl=cosph1(l)*cosph2(k-l)
4917             ssl=sinph1(l)*sinph2(k-l)
4918             scl=sinph1(l)*cosph2(k-l)
4919             csl=cosph1(l)*sinph2(k-l)
4920             cosph1ph2(l,k)=ccl-ssl
4921             cosph1ph2(k,l)=ccl+ssl
4922             sinph1ph2(l,k)=scl+csl
4923             sinph1ph2(k,l)=scl-csl
4924           enddo
4925         enddo
4926         if (lprn) then
4927         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4928      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4929         write (iout,*) "coskt and sinkt"
4930         do k=1,nntheterm
4931           write (iout,*) k,coskt(k),sinkt(k)
4932         enddo
4933         endif
4934         do k=1,ntheterm
4935           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4936           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4937      &      *coskt(k)
4938           if (lprn)
4939      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4940      &     " ethetai",ethetai
4941         enddo
4942         if (lprn) then
4943         write (iout,*) "cosph and sinph"
4944         do k=1,nsingle
4945           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4946         enddo
4947         write (iout,*) "cosph1ph2 and sinph2ph2"
4948         do k=2,ndouble
4949           do l=1,k-1
4950             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4951      &         sinph1ph2(l,k),sinph1ph2(k,l)
4952           enddo
4953         enddo
4954         write(iout,*) "ethetai",ethetai
4955         endif
4956         do m=1,ntheterm2
4957           do k=1,nsingle
4958             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4959      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4960      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4961      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4962             ethetai=ethetai+sinkt(m)*aux
4963             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4964             dephii=dephii+k*sinkt(m)*(
4965      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4966      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4967             dephii1=dephii1+k*sinkt(m)*(
4968      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4969      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4970             if (lprn)
4971      &      write (iout,*) "m",m," k",k," bbthet",
4972      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4973      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4974      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4975      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4976           enddo
4977         enddo
4978         if (lprn)
4979      &  write(iout,*) "ethetai",ethetai
4980         do m=1,ntheterm3
4981           do k=2,ndouble
4982             do l=1,k-1
4983               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4984      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4985      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4986      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4987               ethetai=ethetai+sinkt(m)*aux
4988               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4989               dephii=dephii+l*sinkt(m)*(
4990      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4991      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4992      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4993      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4994               dephii1=dephii1+(k-l)*sinkt(m)*(
4995      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4996      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4997      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4998      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4999               if (lprn) then
5000               write (iout,*) "m",m," k",k," l",l," ffthet",
5001      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
5002      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
5003      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
5004      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
5005               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5006      &            cosph1ph2(k,l)*sinkt(m),
5007      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5008               endif
5009             enddo
5010           enddo
5011         enddo
5012 10      continue
5013 c        lprn1=.true.
5014         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
5015      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
5016      &   phii1*rad2deg,ethetai
5017 c        lprn1=.false.
5018         etheta=etheta+ethetai
5019         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5020         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5021         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5022       enddo
5023       return
5024       end
5025 #endif
5026 #ifdef CRYST_SC
5027 c-----------------------------------------------------------------------------
5028       subroutine esc(escloc)
5029 C Calculate the local energy of a side chain and its derivatives in the
5030 C corresponding virtual-bond valence angles THETA and the spherical angles
5031 C ALPHA and OMEGA.
5032       implicit real*8 (a-h,o-z)
5033       include 'DIMENSIONS'
5034       include 'COMMON.GEO'
5035       include 'COMMON.LOCAL'
5036       include 'COMMON.VAR'
5037       include 'COMMON.INTERACT'
5038       include 'COMMON.DERIV'
5039       include 'COMMON.CHAIN'
5040       include 'COMMON.IOUNITS'
5041       include 'COMMON.NAMES'
5042       include 'COMMON.FFIELD'
5043       include 'COMMON.CONTROL'
5044       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5045      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5046       common /sccalc/ time11,time12,time112,theti,it,nlobit
5047       delta=0.02d0*pi
5048       escloc=0.0D0
5049 c     write (iout,'(a)') 'ESC'
5050       do i=loc_start,loc_end
5051         it=itype(i)
5052         if (it.eq.10) goto 1
5053         nlobit=nlob(it)
5054 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5055 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5056         theti=theta(i+1)-pipol
5057         x(1)=dtan(theti)
5058         x(2)=alph(i)
5059         x(3)=omeg(i)
5060
5061         if (x(2).gt.pi-delta) then
5062           xtemp(1)=x(1)
5063           xtemp(2)=pi-delta
5064           xtemp(3)=x(3)
5065           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5066           xtemp(2)=pi
5067           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5068           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5069      &        escloci,dersc(2))
5070           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5071      &        ddersc0(1),dersc(1))
5072           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5073      &        ddersc0(3),dersc(3))
5074           xtemp(2)=pi-delta
5075           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5076           xtemp(2)=pi
5077           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5078           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5079      &            dersc0(2),esclocbi,dersc02)
5080           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5081      &            dersc12,dersc01)
5082           call splinthet(x(2),0.5d0*delta,ss,ssd)
5083           dersc0(1)=dersc01
5084           dersc0(2)=dersc02
5085           dersc0(3)=0.0d0
5086           do k=1,3
5087             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5088           enddo
5089           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5090 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5091 c    &             esclocbi,ss,ssd
5092           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5093 c         escloci=esclocbi
5094 c         write (iout,*) escloci
5095         else if (x(2).lt.delta) then
5096           xtemp(1)=x(1)
5097           xtemp(2)=delta
5098           xtemp(3)=x(3)
5099           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5100           xtemp(2)=0.0d0
5101           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5102           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5103      &        escloci,dersc(2))
5104           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5105      &        ddersc0(1),dersc(1))
5106           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5107      &        ddersc0(3),dersc(3))
5108           xtemp(2)=delta
5109           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5110           xtemp(2)=0.0d0
5111           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5112           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5113      &            dersc0(2),esclocbi,dersc02)
5114           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5115      &            dersc12,dersc01)
5116           dersc0(1)=dersc01
5117           dersc0(2)=dersc02
5118           dersc0(3)=0.0d0
5119           call splinthet(x(2),0.5d0*delta,ss,ssd)
5120           do k=1,3
5121             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5122           enddo
5123           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5124 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5125 c    &             esclocbi,ss,ssd
5126           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5127 c         write (iout,*) escloci
5128         else
5129           call enesc(x,escloci,dersc,ddummy,.false.)
5130         endif
5131
5132         escloc=escloc+escloci
5133         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5134      &     'escloc',i,escloci
5135 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5136
5137         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5138      &   wscloc*dersc(1)
5139         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5140         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5141     1   continue
5142       enddo
5143       return
5144       end
5145 C---------------------------------------------------------------------------
5146       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5147       implicit real*8 (a-h,o-z)
5148       include 'DIMENSIONS'
5149       include 'COMMON.GEO'
5150       include 'COMMON.LOCAL'
5151       include 'COMMON.IOUNITS'
5152       common /sccalc/ time11,time12,time112,theti,it,nlobit
5153       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5154       double precision contr(maxlob,-1:1)
5155       logical mixed
5156 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5157         escloc_i=0.0D0
5158         do j=1,3
5159           dersc(j)=0.0D0
5160           if (mixed) ddersc(j)=0.0d0
5161         enddo
5162         x3=x(3)
5163
5164 C Because of periodicity of the dependence of the SC energy in omega we have
5165 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5166 C To avoid underflows, first compute & store the exponents.
5167
5168         do iii=-1,1
5169
5170           x(3)=x3+iii*dwapi
5171
5172           do j=1,nlobit
5173             do k=1,3
5174               z(k)=x(k)-censc(k,j,it)
5175             enddo
5176             do k=1,3
5177               Axk=0.0D0
5178               do l=1,3
5179                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5180               enddo
5181               Ax(k,j,iii)=Axk
5182             enddo
5183             expfac=0.0D0
5184             do k=1,3
5185               expfac=expfac+Ax(k,j,iii)*z(k)
5186             enddo
5187             contr(j,iii)=expfac
5188           enddo ! j
5189
5190         enddo ! iii
5191
5192         x(3)=x3
5193 C As in the case of ebend, we want to avoid underflows in exponentiation and
5194 C subsequent NaNs and INFs in energy calculation.
5195 C Find the largest exponent
5196         emin=contr(1,-1)
5197         do iii=-1,1
5198           do j=1,nlobit
5199             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5200           enddo
5201         enddo
5202         emin=0.5D0*emin
5203 cd      print *,'it=',it,' emin=',emin
5204
5205 C Compute the contribution to SC energy and derivatives
5206         do iii=-1,1
5207
5208           do j=1,nlobit
5209 #ifdef OSF
5210             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5211             if(adexp.ne.adexp) adexp=1.0
5212             expfac=dexp(adexp)
5213 #else
5214             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5215 #endif
5216 cd          print *,'j=',j,' expfac=',expfac
5217             escloc_i=escloc_i+expfac
5218             do k=1,3
5219               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5220             enddo
5221             if (mixed) then
5222               do k=1,3,2
5223                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5224      &            +gaussc(k,2,j,it))*expfac
5225               enddo
5226             endif
5227           enddo
5228
5229         enddo ! iii
5230
5231         dersc(1)=dersc(1)/cos(theti)**2
5232         ddersc(1)=ddersc(1)/cos(theti)**2
5233         ddersc(3)=ddersc(3)
5234
5235         escloci=-(dlog(escloc_i)-emin)
5236         do j=1,3
5237           dersc(j)=dersc(j)/escloc_i
5238         enddo
5239         if (mixed) then
5240           do j=1,3,2
5241             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5242           enddo
5243         endif
5244       return
5245       end
5246 C------------------------------------------------------------------------------
5247       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5248       implicit real*8 (a-h,o-z)
5249       include 'DIMENSIONS'
5250       include 'COMMON.GEO'
5251       include 'COMMON.LOCAL'
5252       include 'COMMON.IOUNITS'
5253       common /sccalc/ time11,time12,time112,theti,it,nlobit
5254       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5255       double precision contr(maxlob)
5256       logical mixed
5257
5258       escloc_i=0.0D0
5259
5260       do j=1,3
5261         dersc(j)=0.0D0
5262       enddo
5263
5264       do j=1,nlobit
5265         do k=1,2
5266           z(k)=x(k)-censc(k,j,it)
5267         enddo
5268         z(3)=dwapi
5269         do k=1,3
5270           Axk=0.0D0
5271           do l=1,3
5272             Axk=Axk+gaussc(l,k,j,it)*z(l)
5273           enddo
5274           Ax(k,j)=Axk
5275         enddo
5276         expfac=0.0D0
5277         do k=1,3
5278           expfac=expfac+Ax(k,j)*z(k)
5279         enddo
5280         contr(j)=expfac
5281       enddo ! j
5282
5283 C As in the case of ebend, we want to avoid underflows in exponentiation and
5284 C subsequent NaNs and INFs in energy calculation.
5285 C Find the largest exponent
5286       emin=contr(1)
5287       do j=1,nlobit
5288         if (emin.gt.contr(j)) emin=contr(j)
5289       enddo
5290       emin=0.5D0*emin
5291
5292 C Compute the contribution to SC energy and derivatives
5293
5294       dersc12=0.0d0
5295       do j=1,nlobit
5296         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5297         escloc_i=escloc_i+expfac
5298         do k=1,2
5299           dersc(k)=dersc(k)+Ax(k,j)*expfac
5300         enddo
5301         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5302      &            +gaussc(1,2,j,it))*expfac
5303         dersc(3)=0.0d0
5304       enddo
5305
5306       dersc(1)=dersc(1)/cos(theti)**2
5307       dersc12=dersc12/cos(theti)**2
5308       escloci=-(dlog(escloc_i)-emin)
5309       do j=1,2
5310         dersc(j)=dersc(j)/escloc_i
5311       enddo
5312       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5313       return
5314       end
5315 #else
5316 c----------------------------------------------------------------------------------
5317       subroutine esc(escloc)
5318 C Calculate the local energy of a side chain and its derivatives in the
5319 C corresponding virtual-bond valence angles THETA and the spherical angles
5320 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5321 C added by Urszula Kozlowska. 07/11/2007
5322 C
5323       implicit real*8 (a-h,o-z)
5324       include 'DIMENSIONS'
5325       include 'COMMON.GEO'
5326       include 'COMMON.LOCAL'
5327       include 'COMMON.VAR'
5328       include 'COMMON.SCROT'
5329       include 'COMMON.INTERACT'
5330       include 'COMMON.DERIV'
5331       include 'COMMON.CHAIN'
5332       include 'COMMON.IOUNITS'
5333       include 'COMMON.NAMES'
5334       include 'COMMON.FFIELD'
5335       include 'COMMON.CONTROL'
5336       include 'COMMON.VECTORS'
5337       double precision x_prime(3),y_prime(3),z_prime(3)
5338      &    , sumene,dsc_i,dp2_i,x(65),
5339      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5340      &    de_dxx,de_dyy,de_dzz,de_dt
5341       double precision s1_t,s1_6_t,s2_t,s2_6_t
5342       double precision
5343      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5344      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5345      & dt_dCi(3),dt_dCi1(3)
5346       common /sccalc/ time11,time12,time112,theti,it,nlobit
5347       delta=0.02d0*pi
5348       escloc=0.0D0
5349 c      write(iout,*) "ESC: loc_start",loc_start," loc_end",loc_end
5350       do i=loc_start,loc_end
5351         costtab(i+1) =dcos(theta(i+1))
5352         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5353         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5354         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5355         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5356         cosfac=dsqrt(cosfac2)
5357         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5358         sinfac=dsqrt(sinfac2)
5359         it=itype(i)
5360         if (it.eq.10) goto 1
5361 c
5362 C  Compute the axes of tghe local cartesian coordinates system; store in
5363 c   x_prime, y_prime and z_prime
5364 c
5365         do j=1,3
5366           x_prime(j) = 0.00
5367           y_prime(j) = 0.00
5368           z_prime(j) = 0.00
5369         enddo
5370 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5371 C     &   dc_norm(3,i+nres)
5372         do j = 1,3
5373           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5374           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5375         enddo
5376         do j = 1,3
5377           z_prime(j) = -uz(j,i-1)
5378         enddo
5379 c       write (2,*) "i",i
5380 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5381 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5382 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5383 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5384 c      & " xy",scalar(x_prime(1),y_prime(1)),
5385 c      & " xz",scalar(x_prime(1),z_prime(1)),
5386 c      & " yy",scalar(y_prime(1),y_prime(1)),
5387 c      & " yz",scalar(y_prime(1),z_prime(1)),
5388 c      & " zz",scalar(z_prime(1),z_prime(1))
5389 c
5390 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5391 C to local coordinate system. Store in xx, yy, zz.
5392 c
5393         xx=0.0d0
5394         yy=0.0d0
5395         zz=0.0d0
5396         do j = 1,3
5397           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5398           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5399           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5400         enddo
5401
5402         xxtab(i)=xx
5403         yytab(i)=yy
5404         zztab(i)=zz
5405 C
5406 C Compute the energy of the ith side cbain
5407 C
5408 c        write (2,*) "xx",xx," yy",yy," zz",zz
5409         it=itype(i)
5410         do j = 1,65
5411           x(j) = sc_parmin(j,it)
5412         enddo
5413 #ifdef CHECK_COORD
5414 Cc diagnostics - remove later
5415         xx1 = dcos(alph(2))
5416         yy1 = dsin(alph(2))*dcos(omeg(2))
5417         zz1 = -dsin(alph(2))*dsin(omeg(2))
5418         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5419      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5420      &    xx1,yy1,zz1
5421 C,"  --- ", xx_w,yy_w,zz_w
5422 c end diagnostics
5423 #endif
5424         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5425      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5426      &   + x(10)*yy*zz
5427         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5428      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5429      & + x(20)*yy*zz
5430         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5431      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5432      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5433      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5434      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5435      &  +x(40)*xx*yy*zz
5436         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5437      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5438      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5439      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5440      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5441      &  +x(60)*xx*yy*zz
5442         dsc_i   = 0.743d0+x(61)
5443         dp2_i   = 1.9d0+x(62)
5444         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5445      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5446         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5447      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5448         s1=(1+x(63))/(0.1d0 + dscp1)
5449         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5450         s2=(1+x(65))/(0.1d0 + dscp2)
5451         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5452         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5453      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5454 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5455 c     &   sumene4,
5456 c     &   dscp1,dscp2,sumene
5457 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5458         escloc = escloc + sumene
5459 c        write (2,*) "i",i," escloc",sumene,escloc
5460 #ifdef DEBUG
5461 C
5462 C This section to check the numerical derivatives of the energy of ith side
5463 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5464 C #define DEBUG in the code to turn it on.
5465 C
5466         write (2,*) "sumene               =",sumene
5467         aincr=1.0d-7
5468         xxsave=xx
5469         xx=xx+aincr
5470         write (2,*) xx,yy,zz
5471         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5472         de_dxx_num=(sumenep-sumene)/aincr
5473         xx=xxsave
5474         write (2,*) "xx+ sumene from enesc=",sumenep
5475         yysave=yy
5476         yy=yy+aincr
5477         write (2,*) xx,yy,zz
5478         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5479         de_dyy_num=(sumenep-sumene)/aincr
5480         yy=yysave
5481         write (2,*) "yy+ sumene from enesc=",sumenep
5482         zzsave=zz
5483         zz=zz+aincr
5484         write (2,*) xx,yy,zz
5485         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5486         de_dzz_num=(sumenep-sumene)/aincr
5487         zz=zzsave
5488         write (2,*) "zz+ sumene from enesc=",sumenep
5489         costsave=cost2tab(i+1)
5490         sintsave=sint2tab(i+1)
5491         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5492         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5493         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5494         de_dt_num=(sumenep-sumene)/aincr
5495         write (2,*) " t+ sumene from enesc=",sumenep
5496         cost2tab(i+1)=costsave
5497         sint2tab(i+1)=sintsave
5498 C End of diagnostics section.
5499 #endif
5500 C
5501 C Compute the gradient of esc
5502 C
5503         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5504         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5505         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5506         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5507         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5508         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5509         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5510         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5511         pom1=(sumene3*sint2tab(i+1)+sumene1)
5512      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5513         pom2=(sumene4*cost2tab(i+1)+sumene2)
5514      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5515         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5516         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5517      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5518      &  +x(40)*yy*zz
5519         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5520         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5521      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5522      &  +x(60)*yy*zz
5523         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5524      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5525      &        +(pom1+pom2)*pom_dx
5526 #ifdef DEBUG
5527         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5528 #endif
5529 C
5530         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5531         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5532      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5533      &  +x(40)*xx*zz
5534         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5535         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5536      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5537      &  +x(59)*zz**2 +x(60)*xx*zz
5538         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5539      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5540      &        +(pom1-pom2)*pom_dy
5541 #ifdef DEBUG
5542         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5543 #endif
5544 C
5545         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5546      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5547      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5548      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5549      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5550      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5551      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5552      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5553 #ifdef DEBUG
5554         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5555 #endif
5556 C
5557         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5558      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5559      &  +pom1*pom_dt1+pom2*pom_dt2
5560 #ifdef DEBUG
5561         write(2,*), "de_dt = ", de_dt,de_dt_num
5562 #endif
5563 c
5564 C
5565        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5566        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5567        cosfac2xx=cosfac2*xx
5568        sinfac2yy=sinfac2*yy
5569        do k = 1,3
5570          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5571      &      vbld_inv(i+1)
5572          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5573      &      vbld_inv(i)
5574          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5575          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5576 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5577 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5578 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5579 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5580          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5581          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5582          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5583          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5584          dZZ_Ci1(k)=0.0d0
5585          dZZ_Ci(k)=0.0d0
5586          do j=1,3
5587            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5588            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5589          enddo
5590
5591          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5592          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5593          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5594 c
5595          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5596          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5597        enddo
5598
5599        do k=1,3
5600          dXX_Ctab(k,i)=dXX_Ci(k)
5601          dXX_C1tab(k,i)=dXX_Ci1(k)
5602          dYY_Ctab(k,i)=dYY_Ci(k)
5603          dYY_C1tab(k,i)=dYY_Ci1(k)
5604          dZZ_Ctab(k,i)=dZZ_Ci(k)
5605          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5606          dXX_XYZtab(k,i)=dXX_XYZ(k)
5607          dYY_XYZtab(k,i)=dYY_XYZ(k)
5608          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5609        enddo
5610
5611        do k = 1,3
5612 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5613 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5614 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5615 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5616 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5617 c     &    dt_dci(k)
5618 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5619 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5620          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5621      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5622          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5623      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5624          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5625      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5626        enddo
5627 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5628 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5629
5630 C to check gradient call subroutine check_grad
5631
5632     1 continue
5633       enddo
5634       return
5635       end
5636 c------------------------------------------------------------------------------
5637       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5638       implicit none
5639       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5640      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5641       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5642      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5643      &   + x(10)*yy*zz
5644       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5645      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5646      & + x(20)*yy*zz
5647       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5648      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5649      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5650      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5651      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5652      &  +x(40)*xx*yy*zz
5653       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5654      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5655      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5656      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5657      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5658      &  +x(60)*xx*yy*zz
5659       dsc_i   = 0.743d0+x(61)
5660       dp2_i   = 1.9d0+x(62)
5661       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5662      &          *(xx*cost2+yy*sint2))
5663       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5664      &          *(xx*cost2-yy*sint2))
5665       s1=(1+x(63))/(0.1d0 + dscp1)
5666       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5667       s2=(1+x(65))/(0.1d0 + dscp2)
5668       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5669       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5670      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5671       enesc=sumene
5672       return
5673       end
5674 #endif
5675 c------------------------------------------------------------------------------
5676       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5677 C
5678 C This procedure calculates two-body contact function g(rij) and its derivative:
5679 C
5680 C           eps0ij                                     !       x < -1
5681 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5682 C            0                                         !       x > 1
5683 C
5684 C where x=(rij-r0ij)/delta
5685 C
5686 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5687 C
5688       implicit none
5689       double precision rij,r0ij,eps0ij,fcont,fprimcont
5690       double precision x,x2,x4,delta
5691 c     delta=0.02D0*r0ij
5692 c      delta=0.2D0*r0ij
5693       x=(rij-r0ij)/delta
5694       if (x.lt.-1.0D0) then
5695         fcont=eps0ij
5696         fprimcont=0.0D0
5697       else if (x.le.1.0D0) then
5698         x2=x*x
5699         x4=x2*x2
5700         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5701         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5702       else
5703         fcont=0.0D0
5704         fprimcont=0.0D0
5705       endif
5706       return
5707       end
5708 c------------------------------------------------------------------------------
5709       subroutine splinthet(theti,delta,ss,ssder)
5710       implicit real*8 (a-h,o-z)
5711       include 'DIMENSIONS'
5712       include 'COMMON.VAR'
5713       include 'COMMON.GEO'
5714       thetup=pi-delta
5715       thetlow=delta
5716       if (theti.gt.pipol) then
5717         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5718       else
5719         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5720         ssder=-ssder
5721       endif
5722       return
5723       end
5724 c------------------------------------------------------------------------------
5725       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5726       implicit none
5727       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5728       double precision ksi,ksi2,ksi3,a1,a2,a3
5729       a1=fprim0*delta/(f1-f0)
5730       a2=3.0d0-2.0d0*a1
5731       a3=a1-2.0d0
5732       ksi=(x-x0)/delta
5733       ksi2=ksi*ksi
5734       ksi3=ksi2*ksi
5735       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5736       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5737       return
5738       end
5739 c------------------------------------------------------------------------------
5740       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5741       implicit none
5742       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5743       double precision ksi,ksi2,ksi3,a1,a2,a3
5744       ksi=(x-x0)/delta
5745       ksi2=ksi*ksi
5746       ksi3=ksi2*ksi
5747       a1=fprim0x*delta
5748       a2=3*(f1x-f0x)-2*fprim0x*delta
5749       a3=fprim0x*delta-2*(f1x-f0x)
5750       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5751       return
5752       end
5753 C-----------------------------------------------------------------------------
5754 #ifdef CRYST_TOR
5755 C-----------------------------------------------------------------------------
5756       subroutine etor(etors,edihcnstr)
5757       implicit real*8 (a-h,o-z)
5758       include 'DIMENSIONS'
5759       include 'COMMON.VAR'
5760       include 'COMMON.GEO'
5761       include 'COMMON.LOCAL'
5762       include 'COMMON.TORSION'
5763       include 'COMMON.INTERACT'
5764       include 'COMMON.DERIV'
5765       include 'COMMON.CHAIN'
5766       include 'COMMON.NAMES'
5767       include 'COMMON.IOUNITS'
5768       include 'COMMON.FFIELD'
5769       include 'COMMON.TORCNSTR'
5770       include 'COMMON.CONTROL'
5771       logical lprn
5772 C Set lprn=.true. for debugging
5773       lprn=.false.
5774 c      lprn=.true.
5775       etors=0.0D0
5776       do i=iphi_start,iphi_end
5777       etors_ii=0.0D0
5778         itori=itortyp(itype(i-2))
5779         itori1=itortyp(itype(i-1))
5780         phii=phi(i)
5781         gloci=0.0D0
5782 C Proline-Proline pair is a special case...
5783         if (itori.eq.3 .and. itori1.eq.3) then
5784           if (phii.gt.-dwapi3) then
5785             cosphi=dcos(3*phii)
5786             fac=1.0D0/(1.0D0-cosphi)
5787             etorsi=v1(1,3,3)*fac
5788             etorsi=etorsi+etorsi
5789             etors=etors+etorsi-v1(1,3,3)
5790             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5791             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5792           endif
5793           do j=1,3
5794             v1ij=v1(j+1,itori,itori1)
5795             v2ij=v2(j+1,itori,itori1)
5796             cosphi=dcos(j*phii)
5797             sinphi=dsin(j*phii)
5798             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5799             if (energy_dec) etors_ii=etors_ii+
5800      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5801             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5802           enddo
5803         else
5804           do j=1,nterm_old
5805             v1ij=v1(j,itori,itori1)
5806             v2ij=v2(j,itori,itori1)
5807             cosphi=dcos(j*phii)
5808             sinphi=dsin(j*phii)
5809             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5810             if (energy_dec) etors_ii=etors_ii+
5811      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5812             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5813           enddo
5814         endif
5815         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5816      &        'etor',i,etors_ii
5817         if (lprn)
5818      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5819      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5820      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5821         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5822         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5823       enddo
5824 ! 6/20/98 - dihedral angle constraints
5825       edihcnstr=0.0d0
5826       do i=1,ndih_constr
5827         itori=idih_constr(i)
5828         phii=phi(itori)
5829         difi=phii-phi0(i)
5830         if (difi.gt.drange(i)) then
5831           difi=difi-drange(i)
5832           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5833           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5834         else if (difi.lt.-drange(i)) then
5835           difi=difi+drange(i)
5836           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5837           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5838         endif
5839 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5840 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5841       enddo
5842 !      write (iout,*) 'edihcnstr',edihcnstr
5843       return
5844       end
5845 c------------------------------------------------------------------------------
5846 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
5847       subroutine e_modeller(ehomology_constr)
5848       ehomology_constr=0.0
5849       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
5850       return
5851       end
5852 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
5853
5854 c------------------------------------------------------------------------------
5855       subroutine etor_d(etors_d)
5856       etors_d=0.0d0
5857       return
5858       end
5859 c----------------------------------------------------------------------------
5860 #else
5861       subroutine etor(etors,edihcnstr)
5862       implicit real*8 (a-h,o-z)
5863       include 'DIMENSIONS'
5864       include 'COMMON.VAR'
5865       include 'COMMON.GEO'
5866       include 'COMMON.LOCAL'
5867       include 'COMMON.TORSION'
5868       include 'COMMON.INTERACT'
5869       include 'COMMON.DERIV'
5870       include 'COMMON.CHAIN'
5871       include 'COMMON.NAMES'
5872       include 'COMMON.IOUNITS'
5873       include 'COMMON.FFIELD'
5874       include 'COMMON.TORCNSTR'
5875       include 'COMMON.CONTROL'
5876       logical lprn
5877 C Set lprn=.true. for debugging
5878       lprn=.false.
5879 c     lprn=.true.
5880       etors=0.0D0
5881       do i=iphi_start,iphi_end
5882       etors_ii=0.0D0
5883         itori=itortyp(itype(i-2))
5884         itori1=itortyp(itype(i-1))
5885         phii=phi(i)
5886         gloci=0.0D0
5887 C Regular cosine and sine terms
5888         do j=1,nterm(itori,itori1)
5889           v1ij=v1(j,itori,itori1)
5890           v2ij=v2(j,itori,itori1)
5891           cosphi=dcos(j*phii)
5892           sinphi=dsin(j*phii)
5893           etors=etors+v1ij*cosphi+v2ij*sinphi
5894           if (energy_dec) etors_ii=etors_ii+
5895      &                v1ij*cosphi+v2ij*sinphi
5896           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5897         enddo
5898 C Lorentz terms
5899 C                         v1
5900 C  E = SUM ----------------------------------- - v1
5901 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5902 C
5903         cosphi=dcos(0.5d0*phii)
5904         sinphi=dsin(0.5d0*phii)
5905         do j=1,nlor(itori,itori1)
5906           vl1ij=vlor1(j,itori,itori1)
5907           vl2ij=vlor2(j,itori,itori1)
5908           vl3ij=vlor3(j,itori,itori1)
5909           pom=vl2ij*cosphi+vl3ij*sinphi
5910           pom1=1.0d0/(pom*pom+1.0d0)
5911           etors=etors+vl1ij*pom1
5912           if (energy_dec) etors_ii=etors_ii+
5913      &                vl1ij*pom1
5914           pom=-pom*pom1*pom1
5915           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5916         enddo
5917 C Subtract the constant term
5918         etors=etors-v0(itori,itori1)
5919           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5920      &         'etor',i,etors_ii-v0(itori,itori1)
5921         if (lprn)
5922      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5923      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5924      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5925         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5926 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5927       enddo
5928 ! 6/20/98 - dihedral angle constraints
5929       edihcnstr=0.0d0
5930 c      do i=1,ndih_constr
5931       do i=idihconstr_start,idihconstr_end
5932         itori=idih_constr(i)
5933         phii=phi(itori)
5934         difi=pinorm(phii-phi0(i))
5935         if (difi.gt.drange(i)) then
5936           difi=difi-drange(i)
5937           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5938           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5939         else if (difi.lt.-drange(i)) then
5940           difi=difi+drange(i)
5941           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5942           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5943         else
5944           difi=0.0
5945         endif
5946 c        write (iout,*) "gloci", gloc(i-3,icg)
5947 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5948 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5949 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5950       enddo
5951 cd       write (iout,*) 'edihcnstr',edihcnstr
5952       return
5953       end
5954 c----------------------------------------------------------------------------
5955 c MODELLER restraint function
5956       subroutine e_modeller(ehomology_constr)
5957       implicit real*8 (a-h,o-z)
5958       include 'DIMENSIONS'
5959
5960       integer nnn, i, j, k, ki, irec, l
5961       integer katy, odleglosci, test7
5962       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
5963       real*8 Eval,Erot
5964       real*8 distance(max_template),distancek(max_template),
5965      &    min_odl,godl(max_template),dih_diff(max_template)
5966
5967 c
5968 c     FP - 30/10/2014 Temporary specifications for homology restraints
5969 c
5970       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
5971      &                 sgtheta
5972       double precision, dimension (maxres) :: guscdiff,usc_diff
5973       double precision, dimension (max_template) ::
5974      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
5975      &           theta_diff
5976 c
5977
5978       include 'COMMON.SBRIDGE'
5979       include 'COMMON.CHAIN'
5980       include 'COMMON.GEO'
5981       include 'COMMON.DERIV'
5982       include 'COMMON.LOCAL'
5983       include 'COMMON.INTERACT'
5984       include 'COMMON.VAR'
5985       include 'COMMON.IOUNITS'
5986       include 'COMMON.MD'
5987       include 'COMMON.CONTROL'
5988 c
5989 c     From subroutine Econstr_back
5990 c
5991       include 'COMMON.NAMES'
5992       include 'COMMON.TIME1'
5993 c
5994
5995
5996       do i=1,19
5997         distancek(i)=9999999.9
5998       enddo
5999
6000
6001       odleg=0.0d0
6002
6003 c Pseudo-energy and gradient from homology restraints (MODELLER-like
6004 c function)
6005 C AL 5/2/14 - Introduce list of restraints
6006 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
6007 #ifdef DEBUG
6008       write(iout,*) "------- dist restrs start -------"
6009 #endif
6010       do ii = link_start_homo,link_end_homo
6011          i = ires_homo(ii)
6012          j = jres_homo(ii)
6013          dij=dist(i,j)
6014 c        write (iout,*) "dij(",i,j,") =",dij
6015          do k=1,constr_homology
6016            distance(k)=odl(k,ii)-dij
6017 c          write (iout,*) "distance(",k,") =",distance(k)
6018            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
6019 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
6020 c          write (iout,*) "distancek(",k,") =",distancek(k)
6021 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
6022          enddo
6023
6024          min_odl=minval(distancek)
6025 c        write (iout,* )"min_odl",min_odl
6026 #ifdef DEBUG
6027          write (iout,*) "ij dij",i,j,dij
6028          write (iout,*) "distance",(distance(k),k=1,constr_homology)
6029          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
6030          write (iout,* )"min_odl",min_odl
6031 #endif
6032          odleg2=0.0d0
6033          do k=1,constr_homology
6034 c Nie wiem po co to liczycie jeszcze raz!
6035 c            odleg3=-waga_dist*((distance(i,j,k)**2)/
6036 c     &              (2*(sigma_odl(i,j,k))**2))
6037             godl(k)=dexp(-distancek(k)+min_odl)
6038             odleg2=odleg2+godl(k)
6039
6040 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
6041 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
6042 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
6043 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
6044
6045          enddo
6046 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6047 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6048 #ifdef DEBUG
6049          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
6050          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
6051 #endif
6052          odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
6053 c        write (iout,*) "odleg",odleg ! sum of -ln-s
6054 c Gradient
6055          sum_godl=odleg2
6056          sum_sgodl=0.0d0
6057          do k=1,constr_homology
6058 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6059 c     &           *waga_dist)+min_odl
6060 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
6061            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
6062            sum_sgodl=sum_sgodl+sgodl
6063
6064 c            sgodl2=sgodl2+sgodl
6065 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
6066 c      write(iout,*) "constr_homology=",constr_homology
6067 c      write(iout,*) i, j, k, "TEST K"
6068          enddo
6069
6070          grad_odl3=waga_dist*sum_sgodl/(sum_godl*dij)
6071 c        grad_odl3=sum_sgodl/(sum_godl*dij)
6072
6073
6074 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
6075 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
6076 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
6077
6078 ccc      write(iout,*) godl, sgodl, grad_odl3
6079
6080 c          grad_odl=grad_odl+grad_odl3
6081
6082          do jik=1,3
6083             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
6084 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
6085 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
6086 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6087             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
6088             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
6089 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
6090 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
6091 c         if (i.eq.25.and.j.eq.27) then
6092 c         write(iout,*) "jik",jik,"i",i,"j",j
6093 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
6094 c         write(iout,*) "grad_odl3",grad_odl3
6095 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
6096 c         write(iout,*) "ggodl",ggodl
6097 c         write(iout,*) "ghpbc(",jik,i,")",
6098 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
6099 c     &                 ghpbc(jik,j)
6100 c         endif
6101          enddo
6102 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
6103 ccc     & dLOG(odleg2),"-odleg=", -odleg
6104
6105       enddo ! ii-loop for dist
6106 #ifdef DEBUG
6107       write(iout,*) "------- dist restrs end -------"
6108 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
6109 c    &     waga_d.eq.1.0d0) call sum_gradient
6110 #endif
6111 c Pseudo-energy and gradient from dihedral-angle restraints from
6112 c homology templates
6113 c      write (iout,*) "End of distance loop"
6114 c      call flush(iout)
6115       kat=0.0d0
6116 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
6117 #ifdef DEBUG
6118       write(iout,*) "------- dih restrs start -------"
6119       do i=idihconstr_start_homo,idihconstr_end_homo
6120         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
6121       enddo
6122 #endif
6123       do i=idihconstr_start_homo,idihconstr_end_homo
6124         kat2=0.0d0
6125 c        betai=beta(i,i+1,i+2,i+3)
6126         betai = phi(i+3)
6127 c       write (iout,*) "betai =",betai
6128         do k=1,constr_homology
6129           dih_diff(k)=pinorm(dih(k,i)-betai)
6130 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
6131 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
6132 c     &                                   -(6.28318-dih_diff(i,k))
6133 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
6134 c     &                                   6.28318+dih_diff(i,k)
6135
6136           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
6137 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
6138           gdih(k)=dexp(kat3)
6139           kat2=kat2+gdih(k)
6140 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
6141 c          write(*,*)""
6142         enddo
6143 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
6144 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
6145 #ifdef DEBUG
6146         write (iout,*) "i",i," betai",betai," kat2",kat2
6147         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
6148 #endif
6149         if (kat2.le.1.0d-14) cycle
6150         kat=kat-dLOG(kat2/constr_homology)
6151 c       write (iout,*) "kat",kat ! sum of -ln-s
6152
6153 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
6154 ccc     & dLOG(kat2), "-kat=", -kat
6155
6156 c ----------------------------------------------------------------------
6157 c Gradient
6158 c ----------------------------------------------------------------------
6159
6160         sum_gdih=kat2
6161         sum_sgdih=0.0d0
6162         do k=1,constr_homology
6163           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
6164 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
6165           sum_sgdih=sum_sgdih+sgdih
6166         enddo
6167 c       grad_dih3=sum_sgdih/sum_gdih
6168         grad_dih3=waga_angle*sum_sgdih/sum_gdih
6169
6170 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
6171 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
6172 ccc     & gloc(nphi+i-3,icg)
6173         gloc(i,icg)=gloc(i,icg)+grad_dih3
6174 c        if (i.eq.25) then
6175 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
6176 c        endif
6177 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
6178 ccc     & gloc(nphi+i-3,icg)
6179
6180       enddo ! i-loop for dih
6181 #ifdef DEBUG
6182       write(iout,*) "------- dih restrs end -------"
6183 #endif
6184
6185 c Pseudo-energy and gradient for theta angle restraints from
6186 c homology templates
6187 c FP 01/15 - inserted from econstr_local_test.F, loop structure
6188 c adapted
6189
6190 c
6191 c     For constr_homology reference structures (FP)
6192 c
6193 c     Uconst_back_tot=0.0d0
6194       Eval=0.0d0
6195       Erot=0.0d0
6196 c     Econstr_back legacy
6197       do i=1,nres
6198 c     do i=ithet_start,ithet_end
6199        dutheta(i)=0.0d0
6200 c     enddo
6201 c     do i=loc_start,loc_end
6202         do j=1,3
6203           duscdiff(j,i)=0.0d0
6204           duscdiffx(j,i)=0.0d0
6205         enddo
6206       enddo
6207 c
6208 c     do iref=1,nref
6209 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
6210 c     write (iout,*) "waga_theta",waga_theta
6211       if (waga_theta.gt.0.0d0) then
6212 #ifdef DEBUG
6213       write (iout,*) "usampl",usampl
6214       write(iout,*) "------- theta restrs start -------"
6215 c     do i=ithet_start,ithet_end
6216 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
6217 c     enddo
6218 #endif
6219 c     write (iout,*) "maxres",maxres,"nres",nres
6220
6221       do i=ithet_start,ithet_end
6222 c
6223 c     do i=1,nfrag_back
6224 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
6225 c
6226 c Deviation of theta angles wrt constr_homology ref structures
6227 c
6228         utheta_i=0.0d0 ! argument of Gaussian for single k
6229         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6230 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
6231 c       over residues in a fragment
6232 c       write (iout,*) "theta(",i,")=",theta(i)
6233         do k=1,constr_homology
6234 c
6235 c         dtheta_i=theta(j)-thetaref(j,iref)
6236 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
6237           theta_diff(k)=thetatpl(k,i)-theta(i)
6238 c
6239           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
6240 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
6241           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
6242           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
6243 c         Gradient for single Gaussian restraint in subr Econstr_back
6244 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
6245 c
6246         enddo
6247 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
6248 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
6249
6250 c
6251 c         Gradient for multiple Gaussian restraint
6252         sum_gtheta=gutheta_i
6253         sum_sgtheta=0.0d0
6254         do k=1,constr_homology
6255 c        New generalized expr for multiple Gaussian from Econstr_back
6256          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
6257 c
6258 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
6259           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
6260         enddo
6261 c       grad_theta3=sum_sgtheta/sum_gtheta 1/*theta(i)? s. line below
6262 c       grad_theta3=sum_sgtheta/sum_gtheta
6263 c
6264 c       Final value of gradient using same var as in Econstr_back
6265         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
6266 c       dutheta(i)=sum_sgtheta/sum_gtheta
6267 c
6268 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
6269         Eval=Eval-dLOG(gutheta_i/constr_homology)
6270 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
6271 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
6272 c       Uconst_back=Uconst_back+utheta(i)
6273       enddo ! (i-loop for theta)
6274 #ifdef DEBUG
6275       write(iout,*) "------- theta restrs end -------"
6276 #endif
6277       endif
6278 c
6279 c Deviation of local SC geometry
6280 c
6281 c Separation of two i-loops (instructed by AL - 11/3/2014)
6282 c
6283 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
6284 c     write (iout,*) "waga_d",waga_d
6285
6286 #ifdef DEBUG
6287       write(iout,*) "------- SC restrs start -------"
6288       write (iout,*) "Initial duscdiff,duscdiffx"
6289       do i=loc_start,loc_end
6290         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
6291      &                 (duscdiffx(jik,i),jik=1,3)
6292       enddo
6293 #endif
6294       do i=loc_start,loc_end
6295         usc_diff_i=0.0d0 ! argument of Gaussian for single k
6296         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
6297 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
6298 c       write(iout,*) "xxtab, yytab, zztab"
6299 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
6300         do k=1,constr_homology
6301 c
6302           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6303 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
6304           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6305           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6306 c         write(iout,*) "dxx, dyy, dzz"
6307 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6308 c
6309           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
6310 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
6311 c         uscdiffk(k)=usc_diff(i)
6312           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
6313           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
6314 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
6315 c     &      xxref(j),yyref(j),zzref(j)
6316         enddo
6317 c
6318 c       Gradient
6319 c
6320 c       Generalized expression for multiple Gaussian acc to that for a single
6321 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
6322 c
6323 c       Original implementation
6324 c       sum_guscdiff=guscdiff(i)
6325 c
6326 c       sum_sguscdiff=0.0d0
6327 c       do k=1,constr_homology
6328 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
6329 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
6330 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
6331 c       enddo
6332 c
6333 c       Implementation of new expressions for gradient (Jan. 2015)
6334 c
6335 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
6336         do k=1,constr_homology
6337 c
6338 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
6339 c       before. Now the drivatives should be correct
6340 c
6341           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
6342 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
6343           dyy=-yytpl(k,i)+yytab(i) ! ibid y
6344           dzz=-zztpl(k,i)+zztab(i) ! ibid z
6345 c
6346 c         New implementation
6347 c
6348           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
6349      &                 sigma_d(k,i) ! for the grad wrt r'
6350 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
6351 c
6352 c
6353 c        New implementation
6354          sum_guscdiff = waga_d*sum_guscdiff
6355          do jik=1,3
6356             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
6357      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
6358      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
6359             duscdiff(jik,i)=duscdiff(jik,i)+
6360      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
6361      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
6362             duscdiffx(jik,i)=duscdiffx(jik,i)+
6363      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
6364      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
6365 c
6366 #ifdef DEBUG
6367              write(iout,*) "jik",jik,"i",i
6368              write(iout,*) "dxx, dyy, dzz"
6369              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
6370              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
6371 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
6372 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
6373 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
6374 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
6375 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
6376 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
6377 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
6378 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
6379 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
6380 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
6381 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
6382 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
6383 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
6384 c            endif
6385 #endif
6386          enddo
6387         enddo
6388 c
6389 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
6390 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
6391 c
6392 c        write (iout,*) i," uscdiff",uscdiff(i)
6393 c
6394 c Put together deviations from local geometry
6395
6396 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
6397 c      &            wfrag_back(3,i,iset)*uscdiff(i)
6398         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
6399 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
6400 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
6401 c       Uconst_back=Uconst_back+usc_diff(i)
6402 c
6403 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
6404 c
6405 c     New implment: multiplied by sum_sguscdiff
6406 c
6407
6408       enddo ! (i-loop for dscdiff)
6409
6410 c      endif
6411
6412 #ifdef DEBUG
6413       write(iout,*) "------- SC restrs end -------"
6414         write (iout,*) "------ After SC loop in e_modeller ------"
6415         do i=loc_start,loc_end
6416          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
6417          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
6418         enddo
6419       if (waga_theta.eq.1.0d0) then
6420       write (iout,*) "in e_modeller after SC restr end: dutheta"
6421       do i=ithet_start,ithet_end
6422         write (iout,*) i,dutheta(i)
6423       enddo
6424       endif
6425       if (waga_d.eq.1.0d0) then
6426       write (iout,*) "e_modeller after SC loop: duscdiff/x"
6427       do i=1,nres
6428         write (iout,*) i,(duscdiff(j,i),j=1,3)
6429         write (iout,*) i,(duscdiffx(j,i),j=1,3)
6430       enddo
6431       endif
6432 #endif
6433
6434 c Total energy from homology restraints
6435 #ifdef DEBUG
6436       write (iout,*) "odleg",odleg," kat",kat
6437 #endif
6438 c
6439 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
6440 c
6441 c     ehomology_constr=odleg+kat
6442       ehomology_constr=waga_dist*odleg+waga_angle*kat+waga_theta*Eval
6443      &              +waga_d*Erot
6444 c     write (iout,*) "odleg",odleg," kat",kat," Uconst_back",Uconst_back
6445 c     write (iout,*) "ehomology_constr",ehomology_constr
6446 c     ehomology_constr=odleg+kat+Uconst_back
6447       return
6448 c
6449 c FP 01/15 end
6450 c
6451   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
6452   747 format(a12,i4,i4,i4,f8.3,f8.3)
6453   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
6454   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
6455   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
6456      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
6457       end
6458
6459 c------------------------------------------------------------------------------
6460       subroutine etor_d(etors_d)
6461 C 6/23/01 Compute double torsional energy
6462       implicit real*8 (a-h,o-z)
6463       include 'DIMENSIONS'
6464       include 'COMMON.VAR'
6465       include 'COMMON.GEO'
6466       include 'COMMON.LOCAL'
6467       include 'COMMON.TORSION'
6468       include 'COMMON.INTERACT'
6469       include 'COMMON.DERIV'
6470       include 'COMMON.CHAIN'
6471       include 'COMMON.NAMES'
6472       include 'COMMON.IOUNITS'
6473       include 'COMMON.FFIELD'
6474       include 'COMMON.TORCNSTR'
6475       logical lprn
6476 C Set lprn=.true. for debugging
6477       lprn=.false.
6478 c     lprn=.true.
6479       etors_d=0.0D0
6480       do i=iphid_start,iphid_end
6481         itori=itortyp(itype(i-2))
6482         itori1=itortyp(itype(i-1))
6483         itori2=itortyp(itype(i))
6484         phii=phi(i)
6485         phii1=phi(i+1)
6486         gloci1=0.0D0
6487         gloci2=0.0D0
6488         do j=1,ntermd_1(itori,itori1,itori2)
6489           v1cij=v1c(1,j,itori,itori1,itori2)
6490           v1sij=v1s(1,j,itori,itori1,itori2)
6491           v2cij=v1c(2,j,itori,itori1,itori2)
6492           v2sij=v1s(2,j,itori,itori1,itori2)
6493           cosphi1=dcos(j*phii)
6494           sinphi1=dsin(j*phii)
6495           cosphi2=dcos(j*phii1)
6496           sinphi2=dsin(j*phii1)
6497           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6498      &     v2cij*cosphi2+v2sij*sinphi2
6499           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6500           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6501         enddo
6502         do k=2,ntermd_2(itori,itori1,itori2)
6503           do l=1,k-1
6504             v1cdij = v2c(k,l,itori,itori1,itori2)
6505             v2cdij = v2c(l,k,itori,itori1,itori2)
6506             v1sdij = v2s(k,l,itori,itori1,itori2)
6507             v2sdij = v2s(l,k,itori,itori1,itori2)
6508             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6509             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6510             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6511             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6512             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6513      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6514             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6515      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6516             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6517      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6518           enddo
6519         enddo
6520         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6521         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6522 c        write (iout,*) "gloci", gloc(i-3,icg)
6523       enddo
6524       return
6525       end
6526 #endif
6527 c------------------------------------------------------------------------------
6528       subroutine eback_sc_corr(esccor)
6529 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6530 c        conformational states; temporarily implemented as differences
6531 c        between UNRES torsional potentials (dependent on three types of
6532 c        residues) and the torsional potentials dependent on all 20 types
6533 c        of residues computed from AM1  energy surfaces of terminally-blocked
6534 c        amino-acid residues.
6535       implicit real*8 (a-h,o-z)
6536       include 'DIMENSIONS'
6537       include 'COMMON.VAR'
6538       include 'COMMON.GEO'
6539       include 'COMMON.LOCAL'
6540       include 'COMMON.TORSION'
6541       include 'COMMON.SCCOR'
6542       include 'COMMON.INTERACT'
6543       include 'COMMON.DERIV'
6544       include 'COMMON.CHAIN'
6545       include 'COMMON.NAMES'
6546       include 'COMMON.IOUNITS'
6547       include 'COMMON.FFIELD'
6548       include 'COMMON.CONTROL'
6549       logical lprn
6550 C Set lprn=.true. for debugging
6551       lprn=.false.
6552 c      lprn=.true.
6553 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6554       esccor=0.0D0
6555       do i=itau_start,itau_end
6556         esccor_ii=0.0D0
6557         isccori=isccortyp(itype(i-2))
6558         isccori1=isccortyp(itype(i-1))
6559         phii=phi(i)
6560 cccc  Added 9 May 2012
6561 cc Tauangle is torsional engle depending on the value of first digit
6562 c(see comment below)
6563 cc Omicron is flat angle depending on the value of first digit
6564 c(see comment below)
6565
6566
6567         do intertyp=1,3 !intertyp
6568 cc Added 09 May 2012 (Adasko)
6569 cc  Intertyp means interaction type of backbone mainchain correlation:
6570 c   1 = SC...Ca...Ca...Ca
6571 c   2 = Ca...Ca...Ca...SC
6572 c   3 = SC...Ca...Ca...SCi
6573         gloci=0.0D0
6574         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6575      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6576      &      (itype(i-1).eq.21)))
6577      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6578      &     .or.(itype(i-2).eq.21)))
6579      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6580      &      (itype(i-1).eq.21)))) cycle
6581         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6582         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6583      & cycle
6584         do j=1,nterm_sccor(isccori,isccori1)
6585           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6586           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6587           cosphi=dcos(j*tauangle(intertyp,i))
6588           sinphi=dsin(j*tauangle(intertyp,i))
6589           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6590           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6591         enddo
6592         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6593 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6594 c     &gloc_sc(intertyp,i-3,icg)
6595         if (lprn)
6596      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6597      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6598      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6599      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6600         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6601        enddo !intertyp
6602       enddo
6603 c        do i=1,nres
6604 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6605 c        enddo
6606       return
6607       end
6608 c----------------------------------------------------------------------------
6609       subroutine multibody(ecorr)
6610 C This subroutine calculates multi-body contributions to energy following
6611 C the idea of Skolnick et al. If side chains I and J make a contact and
6612 C at the same time side chains I+1 and J+1 make a contact, an extra
6613 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6614       implicit real*8 (a-h,o-z)
6615       include 'DIMENSIONS'
6616       include 'COMMON.IOUNITS'
6617       include 'COMMON.DERIV'
6618       include 'COMMON.INTERACT'
6619       include 'COMMON.CONTACTS'
6620       double precision gx(3),gx1(3)
6621       logical lprn
6622
6623 C Set lprn=.true. for debugging
6624       lprn=.false.
6625
6626       if (lprn) then
6627         write (iout,'(a)') 'Contact function values:'
6628         do i=nnt,nct-2
6629           write (iout,'(i2,20(1x,i2,f10.5))')
6630      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6631         enddo
6632       endif
6633       ecorr=0.0D0
6634       do i=nnt,nct
6635         do j=1,3
6636           gradcorr(j,i)=0.0D0
6637           gradxorr(j,i)=0.0D0
6638         enddo
6639       enddo
6640       do i=nnt,nct-2
6641
6642         DO ISHIFT = 3,4
6643
6644         i1=i+ishift
6645         num_conti=num_cont(i)
6646         num_conti1=num_cont(i1)
6647         do jj=1,num_conti
6648           j=jcont(jj,i)
6649           do kk=1,num_conti1
6650             j1=jcont(kk,i1)
6651             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6652 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6653 cd   &                   ' ishift=',ishift
6654 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6655 C The system gains extra energy.
6656               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6657             endif   ! j1==j+-ishift
6658           enddo     ! kk
6659         enddo       ! jj
6660
6661         ENDDO ! ISHIFT
6662
6663       enddo         ! i
6664       return
6665       end
6666 c------------------------------------------------------------------------------
6667       double precision function esccorr(i,j,k,l,jj,kk)
6668       implicit real*8 (a-h,o-z)
6669       include 'DIMENSIONS'
6670       include 'COMMON.IOUNITS'
6671       include 'COMMON.DERIV'
6672       include 'COMMON.INTERACT'
6673       include 'COMMON.CONTACTS'
6674       double precision gx(3),gx1(3)
6675       logical lprn
6676       lprn=.false.
6677       eij=facont(jj,i)
6678       ekl=facont(kk,k)
6679 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6680 C Calculate the multi-body contribution to energy.
6681 C Calculate multi-body contributions to the gradient.
6682 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6683 cd   & k,l,(gacont(m,kk,k),m=1,3)
6684       do m=1,3
6685         gx(m) =ekl*gacont(m,jj,i)
6686         gx1(m)=eij*gacont(m,kk,k)
6687         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6688         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6689         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6690         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6691       enddo
6692       do m=i,j-1
6693         do ll=1,3
6694           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6695         enddo
6696       enddo
6697       do m=k,l-1
6698         do ll=1,3
6699           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6700         enddo
6701       enddo
6702       esccorr=-eij*ekl
6703       return
6704       end
6705 c------------------------------------------------------------------------------
6706       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6707 C This subroutine calculates multi-body contributions to hydrogen-bonding
6708       implicit real*8 (a-h,o-z)
6709       include 'DIMENSIONS'
6710       include 'COMMON.IOUNITS'
6711 #ifdef MPI
6712       include "mpif.h"
6713       parameter (max_cont=maxconts)
6714       parameter (max_dim=26)
6715       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6716       double precision zapas(max_dim,maxconts,max_fg_procs),
6717      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6718       common /przechowalnia/ zapas
6719       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6720      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6721 #endif
6722       include 'COMMON.SETUP'
6723       include 'COMMON.FFIELD'
6724       include 'COMMON.DERIV'
6725       include 'COMMON.INTERACT'
6726       include 'COMMON.CONTACTS'
6727       include 'COMMON.CONTROL'
6728       include 'COMMON.LOCAL'
6729       double precision gx(3),gx1(3),time00
6730       logical lprn,ldone
6731
6732 C Set lprn=.true. for debugging
6733       lprn=.false.
6734 #ifdef MPI
6735       n_corr=0
6736       n_corr1=0
6737       if (nfgtasks.le.1) goto 30
6738       if (lprn) then
6739         write (iout,'(a)') 'Contact function values before RECEIVE:'
6740         do i=nnt,nct-2
6741           write (iout,'(2i3,50(1x,i2,f5.2))')
6742      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6743      &    j=1,num_cont_hb(i))
6744         enddo
6745       endif
6746       call flush(iout)
6747       do i=1,ntask_cont_from
6748         ncont_recv(i)=0
6749       enddo
6750       do i=1,ntask_cont_to
6751         ncont_sent(i)=0
6752       enddo
6753 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6754 c     & ntask_cont_to
6755 C Make the list of contacts to send to send to other procesors
6756 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6757 c      call flush(iout)
6758       do i=iturn3_start,iturn3_end
6759 c        write (iout,*) "make contact list turn3",i," num_cont",
6760 c     &    num_cont_hb(i)
6761         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6762       enddo
6763       do i=iturn4_start,iturn4_end
6764 c        write (iout,*) "make contact list turn4",i," num_cont",
6765 c     &   num_cont_hb(i)
6766         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6767       enddo
6768       do ii=1,nat_sent
6769         i=iat_sent(ii)
6770 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6771 c     &    num_cont_hb(i)
6772         do j=1,num_cont_hb(i)
6773         do k=1,4
6774           jjc=jcont_hb(j,i)
6775           iproc=iint_sent_local(k,jjc,ii)
6776 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6777           if (iproc.gt.0) then
6778             ncont_sent(iproc)=ncont_sent(iproc)+1
6779             nn=ncont_sent(iproc)
6780             zapas(1,nn,iproc)=i
6781             zapas(2,nn,iproc)=jjc
6782             zapas(3,nn,iproc)=facont_hb(j,i)
6783             zapas(4,nn,iproc)=ees0p(j,i)
6784             zapas(5,nn,iproc)=ees0m(j,i)
6785             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6786             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6787             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6788             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6789             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6790             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6791             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6792             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6793             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6794             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6795             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6796             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6797             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6798             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6799             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6800             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6801             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6802             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6803             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6804             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6805             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6806           endif
6807         enddo
6808         enddo
6809       enddo
6810       if (lprn) then
6811       write (iout,*)
6812      &  "Numbers of contacts to be sent to other processors",
6813      &  (ncont_sent(i),i=1,ntask_cont_to)
6814       write (iout,*) "Contacts sent"
6815       do ii=1,ntask_cont_to
6816         nn=ncont_sent(ii)
6817         iproc=itask_cont_to(ii)
6818         write (iout,*) nn," contacts to processor",iproc,
6819      &   " of CONT_TO_COMM group"
6820         do i=1,nn
6821           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6822         enddo
6823       enddo
6824       call flush(iout)
6825       endif
6826       CorrelType=477
6827       CorrelID=fg_rank+1
6828       CorrelType1=478
6829       CorrelID1=nfgtasks+fg_rank+1
6830       ireq=0
6831 C Receive the numbers of needed contacts from other processors
6832       do ii=1,ntask_cont_from
6833         iproc=itask_cont_from(ii)
6834         ireq=ireq+1
6835         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6836      &    FG_COMM,req(ireq),IERR)
6837       enddo
6838 c      write (iout,*) "IRECV ended"
6839 c      call flush(iout)
6840 C Send the number of contacts needed by other processors
6841       do ii=1,ntask_cont_to
6842         iproc=itask_cont_to(ii)
6843         ireq=ireq+1
6844         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6845      &    FG_COMM,req(ireq),IERR)
6846       enddo
6847 c      write (iout,*) "ISEND ended"
6848 c      write (iout,*) "number of requests (nn)",ireq
6849       call flush(iout)
6850       if (ireq.gt.0)
6851      &  call MPI_Waitall(ireq,req,status_array,ierr)
6852 c      write (iout,*)
6853 c     &  "Numbers of contacts to be received from other processors",
6854 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6855 c      call flush(iout)
6856 C Receive contacts
6857       ireq=0
6858       do ii=1,ntask_cont_from
6859         iproc=itask_cont_from(ii)
6860         nn=ncont_recv(ii)
6861 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6862 c     &   " of CONT_TO_COMM group"
6863         call flush(iout)
6864         if (nn.gt.0) then
6865           ireq=ireq+1
6866           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6867      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6868 c          write (iout,*) "ireq,req",ireq,req(ireq)
6869         endif
6870       enddo
6871 C Send the contacts to processors that need them
6872       do ii=1,ntask_cont_to
6873         iproc=itask_cont_to(ii)
6874         nn=ncont_sent(ii)
6875 c        write (iout,*) nn," contacts to processor",iproc,
6876 c     &   " of CONT_TO_COMM group"
6877         if (nn.gt.0) then
6878           ireq=ireq+1
6879           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6880      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6881 c          write (iout,*) "ireq,req",ireq,req(ireq)
6882 c          do i=1,nn
6883 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6884 c          enddo
6885         endif
6886       enddo
6887 c      write (iout,*) "number of requests (contacts)",ireq
6888 c      write (iout,*) "req",(req(i),i=1,4)
6889 c      call flush(iout)
6890       if (ireq.gt.0)
6891      & call MPI_Waitall(ireq,req,status_array,ierr)
6892       do iii=1,ntask_cont_from
6893         iproc=itask_cont_from(iii)
6894         nn=ncont_recv(iii)
6895         if (lprn) then
6896         write (iout,*) "Received",nn," contacts from processor",iproc,
6897      &   " of CONT_FROM_COMM group"
6898         call flush(iout)
6899         do i=1,nn
6900           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6901         enddo
6902         call flush(iout)
6903         endif
6904         do i=1,nn
6905           ii=zapas_recv(1,i,iii)
6906 c Flag the received contacts to prevent double-counting
6907           jj=-zapas_recv(2,i,iii)
6908 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6909 c          call flush(iout)
6910           nnn=num_cont_hb(ii)+1
6911           num_cont_hb(ii)=nnn
6912           jcont_hb(nnn,ii)=jj
6913           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6914           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6915           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6916           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6917           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6918           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6919           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6920           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6921           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6922           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6923           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6924           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6925           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6926           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6927           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6928           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6929           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6930           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6931           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6932           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6933           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6934           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6935           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6936           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6937         enddo
6938       enddo
6939       call flush(iout)
6940       if (lprn) then
6941         write (iout,'(a)') 'Contact function values after receive:'
6942         do i=nnt,nct-2
6943           write (iout,'(2i3,50(1x,i3,f5.2))')
6944      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6945      &    j=1,num_cont_hb(i))
6946         enddo
6947         call flush(iout)
6948       endif
6949    30 continue
6950 #endif
6951       if (lprn) then
6952         write (iout,'(a)') 'Contact function values:'
6953         do i=nnt,nct-2
6954           write (iout,'(2i3,50(1x,i3,f5.2))')
6955      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6956      &    j=1,num_cont_hb(i))
6957         enddo
6958       endif
6959       ecorr=0.0D0
6960 C Remove the loop below after debugging !!!
6961       do i=nnt,nct
6962         do j=1,3
6963           gradcorr(j,i)=0.0D0
6964           gradxorr(j,i)=0.0D0
6965         enddo
6966       enddo
6967 C Calculate the local-electrostatic correlation terms
6968       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6969         i1=i+1
6970         num_conti=num_cont_hb(i)
6971         num_conti1=num_cont_hb(i+1)
6972         do jj=1,num_conti
6973           j=jcont_hb(jj,i)
6974           jp=iabs(j)
6975           do kk=1,num_conti1
6976             j1=jcont_hb(kk,i1)
6977             jp1=iabs(j1)
6978 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6979 c     &         ' jj=',jj,' kk=',kk
6980             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6981      &          .or. j.lt.0 .and. j1.gt.0) .and.
6982      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6983 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6984 C The system gains extra energy.
6985               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6986               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6987      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6988               n_corr=n_corr+1
6989             else if (j1.eq.j) then
6990 C Contacts I-J and I-(J+1) occur simultaneously.
6991 C The system loses extra energy.
6992 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6993             endif
6994           enddo ! kk
6995           do kk=1,num_conti
6996             j1=jcont_hb(kk,i)
6997 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6998 c    &         ' jj=',jj,' kk=',kk
6999             if (j1.eq.j+1) then
7000 C Contacts I-J and (I+1)-J occur simultaneously.
7001 C The system loses extra energy.
7002 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7003             endif ! j1==j+1
7004           enddo ! kk
7005         enddo ! jj
7006       enddo ! i
7007       return
7008       end
7009 c------------------------------------------------------------------------------
7010       subroutine add_hb_contact(ii,jj,itask)
7011       implicit real*8 (a-h,o-z)
7012       include "DIMENSIONS"
7013       include "COMMON.IOUNITS"
7014       integer max_cont
7015       integer max_dim
7016       parameter (max_cont=maxconts)
7017       parameter (max_dim=26)
7018       include "COMMON.CONTACTS"
7019       double precision zapas(max_dim,maxconts,max_fg_procs),
7020      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7021       common /przechowalnia/ zapas
7022       integer i,j,ii,jj,iproc,itask(4),nn
7023 c      write (iout,*) "itask",itask
7024       do i=1,2
7025         iproc=itask(i)
7026         if (iproc.gt.0) then
7027           do j=1,num_cont_hb(ii)
7028             jjc=jcont_hb(j,ii)
7029 c            write (iout,*) "i",ii," j",jj," jjc",jjc
7030             if (jjc.eq.jj) then
7031               ncont_sent(iproc)=ncont_sent(iproc)+1
7032               nn=ncont_sent(iproc)
7033               zapas(1,nn,iproc)=ii
7034               zapas(2,nn,iproc)=jjc
7035               zapas(3,nn,iproc)=facont_hb(j,ii)
7036               zapas(4,nn,iproc)=ees0p(j,ii)
7037               zapas(5,nn,iproc)=ees0m(j,ii)
7038               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7039               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7040               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7041               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7042               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7043               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7044               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7045               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7046               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7047               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7048               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7049               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7050               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7051               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7052               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7053               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7054               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7055               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7056               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7057               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7058               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7059               exit
7060             endif
7061           enddo
7062         endif
7063       enddo
7064       return
7065       end
7066 c------------------------------------------------------------------------------
7067       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7068      &  n_corr1)
7069 C This subroutine calculates multi-body contributions to hydrogen-bonding
7070       implicit real*8 (a-h,o-z)
7071       include 'DIMENSIONS'
7072       include 'COMMON.IOUNITS'
7073 #ifdef MPI
7074       include "mpif.h"
7075       parameter (max_cont=maxconts)
7076       parameter (max_dim=70)
7077       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7078       double precision zapas(max_dim,maxconts,max_fg_procs),
7079      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7080       common /przechowalnia/ zapas
7081       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7082      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7083 #endif
7084       include 'COMMON.SETUP'
7085       include 'COMMON.FFIELD'
7086       include 'COMMON.DERIV'
7087       include 'COMMON.LOCAL'
7088       include 'COMMON.INTERACT'
7089       include 'COMMON.CONTACTS'
7090       include 'COMMON.CHAIN'
7091       include 'COMMON.CONTROL'
7092       double precision gx(3),gx1(3)
7093       integer num_cont_hb_old(maxres)
7094       logical lprn,ldone
7095       double precision eello4,eello5,eelo6,eello_turn6
7096       external eello4,eello5,eello6,eello_turn6
7097 C Set lprn=.true. for debugging
7098       lprn=.false.
7099       eturn6=0.0d0
7100 #ifdef MPI
7101       do i=1,nres
7102         num_cont_hb_old(i)=num_cont_hb(i)
7103       enddo
7104       n_corr=0
7105       n_corr1=0
7106       if (nfgtasks.le.1) goto 30
7107       if (lprn) then
7108         write (iout,'(a)') 'Contact function values before RECEIVE:'
7109         do i=nnt,nct-2
7110           write (iout,'(2i3,50(1x,i2,f5.2))')
7111      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7112      &    j=1,num_cont_hb(i))
7113         enddo
7114       endif
7115       call flush(iout)
7116       do i=1,ntask_cont_from
7117         ncont_recv(i)=0
7118       enddo
7119       do i=1,ntask_cont_to
7120         ncont_sent(i)=0
7121       enddo
7122 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7123 c     & ntask_cont_to
7124 C Make the list of contacts to send to send to other procesors
7125       do i=iturn3_start,iturn3_end
7126 c        write (iout,*) "make contact list turn3",i," num_cont",
7127 c     &    num_cont_hb(i)
7128         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7129       enddo
7130       do i=iturn4_start,iturn4_end
7131 c        write (iout,*) "make contact list turn4",i," num_cont",
7132 c     &   num_cont_hb(i)
7133         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7134       enddo
7135       do ii=1,nat_sent
7136         i=iat_sent(ii)
7137 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
7138 c     &    num_cont_hb(i)
7139         do j=1,num_cont_hb(i)
7140         do k=1,4
7141           jjc=jcont_hb(j,i)
7142           iproc=iint_sent_local(k,jjc,ii)
7143 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7144           if (iproc.ne.0) then
7145             ncont_sent(iproc)=ncont_sent(iproc)+1
7146             nn=ncont_sent(iproc)
7147             zapas(1,nn,iproc)=i
7148             zapas(2,nn,iproc)=jjc
7149             zapas(3,nn,iproc)=d_cont(j,i)
7150             ind=3
7151             do kk=1,3
7152               ind=ind+1
7153               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7154             enddo
7155             do kk=1,2
7156               do ll=1,2
7157                 ind=ind+1
7158                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7159               enddo
7160             enddo
7161             do jj=1,5
7162               do kk=1,3
7163                 do ll=1,2
7164                   do mm=1,2
7165                     ind=ind+1
7166                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7167                   enddo
7168                 enddo
7169               enddo
7170             enddo
7171           endif
7172         enddo
7173         enddo
7174       enddo
7175       if (lprn) then
7176       write (iout,*)
7177      &  "Numbers of contacts to be sent to other processors",
7178      &  (ncont_sent(i),i=1,ntask_cont_to)
7179       write (iout,*) "Contacts sent"
7180       do ii=1,ntask_cont_to
7181         nn=ncont_sent(ii)
7182         iproc=itask_cont_to(ii)
7183         write (iout,*) nn," contacts to processor",iproc,
7184      &   " of CONT_TO_COMM group"
7185         do i=1,nn
7186           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7187         enddo
7188       enddo
7189       call flush(iout)
7190       endif
7191       CorrelType=477
7192       CorrelID=fg_rank+1
7193       CorrelType1=478
7194       CorrelID1=nfgtasks+fg_rank+1
7195       ireq=0
7196 C Receive the numbers of needed contacts from other processors
7197       do ii=1,ntask_cont_from
7198         iproc=itask_cont_from(ii)
7199         ireq=ireq+1
7200         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
7201      &    FG_COMM,req(ireq),IERR)
7202       enddo
7203 c      write (iout,*) "IRECV ended"
7204 c      call flush(iout)
7205 C Send the number of contacts needed by other processors
7206       do ii=1,ntask_cont_to
7207         iproc=itask_cont_to(ii)
7208         ireq=ireq+1
7209         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
7210      &    FG_COMM,req(ireq),IERR)
7211       enddo
7212 c      write (iout,*) "ISEND ended"
7213 c      write (iout,*) "number of requests (nn)",ireq
7214       call flush(iout)
7215       if (ireq.gt.0)
7216      &  call MPI_Waitall(ireq,req,status_array,ierr)
7217 c      write (iout,*)
7218 c     &  "Numbers of contacts to be received from other processors",
7219 c     &  (ncont_recv(i),i=1,ntask_cont_from)
7220 c      call flush(iout)
7221 C Receive contacts
7222       ireq=0
7223       do ii=1,ntask_cont_from
7224         iproc=itask_cont_from(ii)
7225         nn=ncont_recv(ii)
7226 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7227 c     &   " of CONT_TO_COMM group"
7228         call flush(iout)
7229         if (nn.gt.0) then
7230           ireq=ireq+1
7231           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
7232      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7233 c          write (iout,*) "ireq,req",ireq,req(ireq)
7234         endif
7235       enddo
7236 C Send the contacts to processors that need them
7237       do ii=1,ntask_cont_to
7238         iproc=itask_cont_to(ii)
7239         nn=ncont_sent(ii)
7240 c        write (iout,*) nn," contacts to processor",iproc,
7241 c     &   " of CONT_TO_COMM group"
7242         if (nn.gt.0) then
7243           ireq=ireq+1
7244           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
7245      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7246 c          write (iout,*) "ireq,req",ireq,req(ireq)
7247 c          do i=1,nn
7248 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7249 c          enddo
7250         endif
7251       enddo
7252 c      write (iout,*) "number of requests (contacts)",ireq
7253 c      write (iout,*) "req",(req(i),i=1,4)
7254 c      call flush(iout)
7255       if (ireq.gt.0)
7256      & call MPI_Waitall(ireq,req,status_array,ierr)
7257       do iii=1,ntask_cont_from
7258         iproc=itask_cont_from(iii)
7259         nn=ncont_recv(iii)
7260         if (lprn) then
7261         write (iout,*) "Received",nn," contacts from processor",iproc,
7262      &   " of CONT_FROM_COMM group"
7263         call flush(iout)
7264         do i=1,nn
7265           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7266         enddo
7267         call flush(iout)
7268         endif
7269         do i=1,nn
7270           ii=zapas_recv(1,i,iii)
7271 c Flag the received contacts to prevent double-counting
7272           jj=-zapas_recv(2,i,iii)
7273 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7274 c          call flush(iout)
7275           nnn=num_cont_hb(ii)+1
7276           num_cont_hb(ii)=nnn
7277           jcont_hb(nnn,ii)=jj
7278           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7279           ind=3
7280           do kk=1,3
7281             ind=ind+1
7282             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7283           enddo
7284           do kk=1,2
7285             do ll=1,2
7286               ind=ind+1
7287               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7288             enddo
7289           enddo
7290           do jj=1,5
7291             do kk=1,3
7292               do ll=1,2
7293                 do mm=1,2
7294                   ind=ind+1
7295                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7296                 enddo
7297               enddo
7298             enddo
7299           enddo
7300         enddo
7301       enddo
7302       call flush(iout)
7303       if (lprn) then
7304         write (iout,'(a)') 'Contact function values after receive:'
7305         do i=nnt,nct-2
7306           write (iout,'(2i3,50(1x,i3,5f6.3))')
7307      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7308      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7309         enddo
7310         call flush(iout)
7311       endif
7312    30 continue
7313 #endif
7314       if (lprn) then
7315         write (iout,'(a)') 'Contact function values:'
7316         do i=nnt,nct-2
7317           write (iout,'(2i3,50(1x,i2,5f6.3))')
7318      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7319      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7320         enddo
7321       endif
7322       ecorr=0.0D0
7323       ecorr5=0.0d0
7324       ecorr6=0.0d0
7325 C Remove the loop below after debugging !!!
7326       do i=nnt,nct
7327         do j=1,3
7328           gradcorr(j,i)=0.0D0
7329           gradxorr(j,i)=0.0D0
7330         enddo
7331       enddo
7332 C Calculate the dipole-dipole interaction energies
7333       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7334       do i=iatel_s,iatel_e+1
7335         num_conti=num_cont_hb(i)
7336         do jj=1,num_conti
7337           j=jcont_hb(jj,i)
7338 #ifdef MOMENT
7339           call dipole(i,j,jj)
7340 #endif
7341         enddo
7342       enddo
7343       endif
7344 C Calculate the local-electrostatic correlation terms
7345 c                write (iout,*) "gradcorr5 in eello5 before loop"
7346 c                do iii=1,nres
7347 c                  write (iout,'(i5,3f10.5)')
7348 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7349 c                enddo
7350       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7351 c        write (iout,*) "corr loop i",i
7352         i1=i+1
7353         num_conti=num_cont_hb(i)
7354         num_conti1=num_cont_hb(i+1)
7355         do jj=1,num_conti
7356           j=jcont_hb(jj,i)
7357           jp=iabs(j)
7358           do kk=1,num_conti1
7359             j1=jcont_hb(kk,i1)
7360             jp1=iabs(j1)
7361 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7362 c     &         ' jj=',jj,' kk=',kk
7363 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7364             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7365      &          .or. j.lt.0 .and. j1.gt.0) .and.
7366      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7367 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7368 C The system gains extra energy.
7369               n_corr=n_corr+1
7370               sqd1=dsqrt(d_cont(jj,i))
7371               sqd2=dsqrt(d_cont(kk,i1))
7372               sred_geom = sqd1*sqd2
7373               IF (sred_geom.lt.cutoff_corr) THEN
7374                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7375      &            ekont,fprimcont)
7376 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7377 cd     &         ' jj=',jj,' kk=',kk
7378                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7379                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7380                 do l=1,3
7381                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7382                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7383                 enddo
7384                 n_corr1=n_corr1+1
7385 cd               write (iout,*) 'sred_geom=',sred_geom,
7386 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7387 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7388 cd               write (iout,*) "g_contij",g_contij
7389 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7390 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7391                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7392                 if (wcorr4.gt.0.0d0)
7393      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7394                   if (energy_dec.and.wcorr4.gt.0.0d0)
7395      1                 write (iout,'(a6,4i5,0pf7.3)')
7396      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7397 c                write (iout,*) "gradcorr5 before eello5"
7398 c                do iii=1,nres
7399 c                  write (iout,'(i5,3f10.5)')
7400 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7401 c                enddo
7402                 if (wcorr5.gt.0.0d0)
7403      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7404 c                write (iout,*) "gradcorr5 after eello5"
7405 c                do iii=1,nres
7406 c                  write (iout,'(i5,3f10.5)')
7407 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7408 c                enddo
7409                   if (energy_dec.and.wcorr5.gt.0.0d0)
7410      1                 write (iout,'(a6,4i5,0pf7.3)')
7411      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7412 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7413 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7414                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7415      &               .or. wturn6.eq.0.0d0))then
7416 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7417                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7418                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7419      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7420 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7421 cd     &            'ecorr6=',ecorr6
7422 cd                write (iout,'(4e15.5)') sred_geom,
7423 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7424 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7425 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7426                 else if (wturn6.gt.0.0d0
7427      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7428 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7429                   eturn6=eturn6+eello_turn6(i,jj,kk)
7430                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7431      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7432 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
7433                 endif
7434               ENDIF
7435 1111          continue
7436             endif
7437           enddo ! kk
7438         enddo ! jj
7439       enddo ! i
7440       do i=1,nres
7441         num_cont_hb(i)=num_cont_hb_old(i)
7442       enddo
7443 c                write (iout,*) "gradcorr5 in eello5"
7444 c                do iii=1,nres
7445 c                  write (iout,'(i5,3f10.5)')
7446 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7447 c                enddo
7448       return
7449       end
7450 c------------------------------------------------------------------------------
7451       subroutine add_hb_contact_eello(ii,jj,itask)
7452       implicit real*8 (a-h,o-z)
7453       include "DIMENSIONS"
7454       include "COMMON.IOUNITS"
7455       integer max_cont
7456       integer max_dim
7457       parameter (max_cont=maxconts)
7458       parameter (max_dim=70)
7459       include "COMMON.CONTACTS"
7460       double precision zapas(max_dim,maxconts,max_fg_procs),
7461      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7462       common /przechowalnia/ zapas
7463       integer i,j,ii,jj,iproc,itask(4),nn
7464 c      write (iout,*) "itask",itask
7465       do i=1,2
7466         iproc=itask(i)
7467         if (iproc.gt.0) then
7468           do j=1,num_cont_hb(ii)
7469             jjc=jcont_hb(j,ii)
7470 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7471             if (jjc.eq.jj) then
7472               ncont_sent(iproc)=ncont_sent(iproc)+1
7473               nn=ncont_sent(iproc)
7474               zapas(1,nn,iproc)=ii
7475               zapas(2,nn,iproc)=jjc
7476               zapas(3,nn,iproc)=d_cont(j,ii)
7477               ind=3
7478               do kk=1,3
7479                 ind=ind+1
7480                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7481               enddo
7482               do kk=1,2
7483                 do ll=1,2
7484                   ind=ind+1
7485                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7486                 enddo
7487               enddo
7488               do jj=1,5
7489                 do kk=1,3
7490                   do ll=1,2
7491                     do mm=1,2
7492                       ind=ind+1
7493                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7494                     enddo
7495                   enddo
7496                 enddo
7497               enddo
7498               exit
7499             endif
7500           enddo
7501         endif
7502       enddo
7503       return
7504       end
7505 c------------------------------------------------------------------------------
7506       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7507       implicit real*8 (a-h,o-z)
7508       include 'DIMENSIONS'
7509       include 'COMMON.IOUNITS'
7510       include 'COMMON.DERIV'
7511       include 'COMMON.INTERACT'
7512       include 'COMMON.CONTACTS'
7513       double precision gx(3),gx1(3)
7514       logical lprn
7515       lprn=.false.
7516       eij=facont_hb(jj,i)
7517       ekl=facont_hb(kk,k)
7518       ees0pij=ees0p(jj,i)
7519       ees0pkl=ees0p(kk,k)
7520       ees0mij=ees0m(jj,i)
7521       ees0mkl=ees0m(kk,k)
7522       ekont=eij*ekl
7523       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
7524 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
7525 C Following 4 lines for diagnostics.
7526 cd    ees0pkl=0.0D0
7527 cd    ees0pij=1.0D0
7528 cd    ees0mkl=0.0D0
7529 cd    ees0mij=1.0D0
7530 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7531 c     & 'Contacts ',i,j,
7532 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7533 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7534 c     & 'gradcorr_long'
7535 C Calculate the multi-body contribution to energy.
7536 c      ecorr=ecorr+ekont*ees
7537 C Calculate multi-body contributions to the gradient.
7538       coeffpees0pij=coeffp*ees0pij
7539       coeffmees0mij=coeffm*ees0mij
7540       coeffpees0pkl=coeffp*ees0pkl
7541       coeffmees0mkl=coeffm*ees0mkl
7542       do ll=1,3
7543 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7544         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7545      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7546      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7547         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7548      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7549      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7550 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7551         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7552      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7553      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7554         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7555      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7556      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7557         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7558      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7559      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7560         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7561         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7562         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7563      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7564      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7565         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7566         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7567 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7568       enddo
7569 c      write (iout,*)
7570 cgrad      do m=i+1,j-1
7571 cgrad        do ll=1,3
7572 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7573 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7574 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7575 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7576 cgrad        enddo
7577 cgrad      enddo
7578 cgrad      do m=k+1,l-1
7579 cgrad        do ll=1,3
7580 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7581 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7582 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7583 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7584 cgrad        enddo
7585 cgrad      enddo
7586 c      write (iout,*) "ehbcorr",ekont*ees
7587       ehbcorr=ekont*ees
7588       return
7589       end
7590 #ifdef MOMENT
7591 C---------------------------------------------------------------------------
7592       subroutine dipole(i,j,jj)
7593       implicit real*8 (a-h,o-z)
7594       include 'DIMENSIONS'
7595       include 'COMMON.IOUNITS'
7596       include 'COMMON.CHAIN'
7597       include 'COMMON.FFIELD'
7598       include 'COMMON.DERIV'
7599       include 'COMMON.INTERACT'
7600       include 'COMMON.CONTACTS'
7601       include 'COMMON.TORSION'
7602       include 'COMMON.VAR'
7603       include 'COMMON.GEO'
7604       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7605      &  auxmat(2,2)
7606       iti1 = itortyp(itype(i+1))
7607       if (j.lt.nres-1) then
7608         itj1 = itortyp(itype(j+1))
7609       else
7610         itj1=ntortyp+1
7611       endif
7612       do iii=1,2
7613         dipi(iii,1)=Ub2(iii,i)
7614         dipderi(iii)=Ub2der(iii,i)
7615         dipi(iii,2)=b1(iii,iti1)
7616         dipj(iii,1)=Ub2(iii,j)
7617         dipderj(iii)=Ub2der(iii,j)
7618         dipj(iii,2)=b1(iii,itj1)
7619       enddo
7620       kkk=0
7621       do iii=1,2
7622         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7623         do jjj=1,2
7624           kkk=kkk+1
7625           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7626         enddo
7627       enddo
7628       do kkk=1,5
7629         do lll=1,3
7630           mmm=0
7631           do iii=1,2
7632             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7633      &        auxvec(1))
7634             do jjj=1,2
7635               mmm=mmm+1
7636               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7637             enddo
7638           enddo
7639         enddo
7640       enddo
7641       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7642       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7643       do iii=1,2
7644         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7645       enddo
7646       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7647       do iii=1,2
7648         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7649       enddo
7650       return
7651       end
7652 #endif
7653 C---------------------------------------------------------------------------
7654       subroutine calc_eello(i,j,k,l,jj,kk)
7655 C
7656 C This subroutine computes matrices and vectors needed to calculate
7657 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7658 C
7659       implicit real*8 (a-h,o-z)
7660       include 'DIMENSIONS'
7661       include 'COMMON.IOUNITS'
7662       include 'COMMON.CHAIN'
7663       include 'COMMON.DERIV'
7664       include 'COMMON.INTERACT'
7665       include 'COMMON.CONTACTS'
7666       include 'COMMON.TORSION'
7667       include 'COMMON.VAR'
7668       include 'COMMON.GEO'
7669       include 'COMMON.FFIELD'
7670       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7671      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7672       logical lprn
7673       common /kutas/ lprn
7674 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7675 cd     & ' jj=',jj,' kk=',kk
7676 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7677 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7678 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7679       do iii=1,2
7680         do jjj=1,2
7681           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7682           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7683         enddo
7684       enddo
7685       call transpose2(aa1(1,1),aa1t(1,1))
7686       call transpose2(aa2(1,1),aa2t(1,1))
7687       do kkk=1,5
7688         do lll=1,3
7689           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7690      &      aa1tder(1,1,lll,kkk))
7691           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7692      &      aa2tder(1,1,lll,kkk))
7693         enddo
7694       enddo
7695       if (l.eq.j+1) then
7696 C parallel orientation of the two CA-CA-CA frames.
7697         if (i.gt.1) then
7698           iti=itortyp(itype(i))
7699         else
7700           iti=ntortyp+1
7701         endif
7702         itk1=itortyp(itype(k+1))
7703         itj=itortyp(itype(j))
7704         if (l.lt.nres-1) then
7705           itl1=itortyp(itype(l+1))
7706         else
7707           itl1=ntortyp+1
7708         endif
7709 C A1 kernel(j+1) A2T
7710 cd        do iii=1,2
7711 cd          write (iout,'(3f10.5,5x,3f10.5)')
7712 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7713 cd        enddo
7714         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7715      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7716      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7717 C Following matrices are needed only for 6-th order cumulants
7718         IF (wcorr6.gt.0.0d0) THEN
7719         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7720      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7721      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7722         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7723      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7724      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7725      &   ADtEAderx(1,1,1,1,1,1))
7726         lprn=.false.
7727         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7728      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7729      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7730      &   ADtEA1derx(1,1,1,1,1,1))
7731         ENDIF
7732 C End 6-th order cumulants
7733 cd        lprn=.false.
7734 cd        if (lprn) then
7735 cd        write (2,*) 'In calc_eello6'
7736 cd        do iii=1,2
7737 cd          write (2,*) 'iii=',iii
7738 cd          do kkk=1,5
7739 cd            write (2,*) 'kkk=',kkk
7740 cd            do jjj=1,2
7741 cd              write (2,'(3(2f10.5),5x)')
7742 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7743 cd            enddo
7744 cd          enddo
7745 cd        enddo
7746 cd        endif
7747         call transpose2(EUgder(1,1,k),auxmat(1,1))
7748         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7749         call transpose2(EUg(1,1,k),auxmat(1,1))
7750         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7751         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7752         do iii=1,2
7753           do kkk=1,5
7754             do lll=1,3
7755               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7756      &          EAEAderx(1,1,lll,kkk,iii,1))
7757             enddo
7758           enddo
7759         enddo
7760 C A1T kernel(i+1) A2
7761         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7762      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7763      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7764 C Following matrices are needed only for 6-th order cumulants
7765         IF (wcorr6.gt.0.0d0) THEN
7766         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7767      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7768      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7769         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7770      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7771      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7772      &   ADtEAderx(1,1,1,1,1,2))
7773         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7774      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7775      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7776      &   ADtEA1derx(1,1,1,1,1,2))
7777         ENDIF
7778 C End 6-th order cumulants
7779         call transpose2(EUgder(1,1,l),auxmat(1,1))
7780         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7781         call transpose2(EUg(1,1,l),auxmat(1,1))
7782         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7783         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7784         do iii=1,2
7785           do kkk=1,5
7786             do lll=1,3
7787               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7788      &          EAEAderx(1,1,lll,kkk,iii,2))
7789             enddo
7790           enddo
7791         enddo
7792 C AEAb1 and AEAb2
7793 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7794 C They are needed only when the fifth- or the sixth-order cumulants are
7795 C indluded.
7796         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7797         call transpose2(AEA(1,1,1),auxmat(1,1))
7798         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7799         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7800         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7801         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7802         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7803         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7804         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7805         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7806         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7807         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7808         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7809         call transpose2(AEA(1,1,2),auxmat(1,1))
7810         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7811         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7812         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7813         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7814         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7815         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7816         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7817         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7818         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7819         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7820         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7821 C Calculate the Cartesian derivatives of the vectors.
7822         do iii=1,2
7823           do kkk=1,5
7824             do lll=1,3
7825               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7826               call matvec2(auxmat(1,1),b1(1,iti),
7827      &          AEAb1derx(1,lll,kkk,iii,1,1))
7828               call matvec2(auxmat(1,1),Ub2(1,i),
7829      &          AEAb2derx(1,lll,kkk,iii,1,1))
7830               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7831      &          AEAb1derx(1,lll,kkk,iii,2,1))
7832               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7833      &          AEAb2derx(1,lll,kkk,iii,2,1))
7834               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7835               call matvec2(auxmat(1,1),b1(1,itj),
7836      &          AEAb1derx(1,lll,kkk,iii,1,2))
7837               call matvec2(auxmat(1,1),Ub2(1,j),
7838      &          AEAb2derx(1,lll,kkk,iii,1,2))
7839               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7840      &          AEAb1derx(1,lll,kkk,iii,2,2))
7841               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7842      &          AEAb2derx(1,lll,kkk,iii,2,2))
7843             enddo
7844           enddo
7845         enddo
7846         ENDIF
7847 C End vectors
7848       else
7849 C Antiparallel orientation of the two CA-CA-CA frames.
7850         if (i.gt.1) then
7851           iti=itortyp(itype(i))
7852         else
7853           iti=ntortyp+1
7854         endif
7855         itk1=itortyp(itype(k+1))
7856         itl=itortyp(itype(l))
7857         itj=itortyp(itype(j))
7858         if (j.lt.nres-1) then
7859           itj1=itortyp(itype(j+1))
7860         else
7861           itj1=ntortyp+1
7862         endif
7863 C A2 kernel(j-1)T A1T
7864         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7865      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7866      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7867 C Following matrices are needed only for 6-th order cumulants
7868         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7869      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7870         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7871      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7872      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7873         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7874      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7875      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7876      &   ADtEAderx(1,1,1,1,1,1))
7877         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7878      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7879      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7880      &   ADtEA1derx(1,1,1,1,1,1))
7881         ENDIF
7882 C End 6-th order cumulants
7883         call transpose2(EUgder(1,1,k),auxmat(1,1))
7884         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7885         call transpose2(EUg(1,1,k),auxmat(1,1))
7886         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7887         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7888         do iii=1,2
7889           do kkk=1,5
7890             do lll=1,3
7891               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7892      &          EAEAderx(1,1,lll,kkk,iii,1))
7893             enddo
7894           enddo
7895         enddo
7896 C A2T kernel(i+1)T A1
7897         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7898      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7899      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7900 C Following matrices are needed only for 6-th order cumulants
7901         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7902      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7903         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7904      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7905      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7906         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7907      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7908      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7909      &   ADtEAderx(1,1,1,1,1,2))
7910         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7911      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7912      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7913      &   ADtEA1derx(1,1,1,1,1,2))
7914         ENDIF
7915 C End 6-th order cumulants
7916         call transpose2(EUgder(1,1,j),auxmat(1,1))
7917         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7918         call transpose2(EUg(1,1,j),auxmat(1,1))
7919         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7920         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7921         do iii=1,2
7922           do kkk=1,5
7923             do lll=1,3
7924               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7925      &          EAEAderx(1,1,lll,kkk,iii,2))
7926             enddo
7927           enddo
7928         enddo
7929 C AEAb1 and AEAb2
7930 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7931 C They are needed only when the fifth- or the sixth-order cumulants are
7932 C indluded.
7933         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7934      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7935         call transpose2(AEA(1,1,1),auxmat(1,1))
7936         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7937         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7938         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7939         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7940         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7941         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7942         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7943         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7944         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7945         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7946         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7947         call transpose2(AEA(1,1,2),auxmat(1,1))
7948         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7949         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7950         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7951         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7952         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7953         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7954         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7955         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7956         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7957         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7958         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7959 C Calculate the Cartesian derivatives of the vectors.
7960         do iii=1,2
7961           do kkk=1,5
7962             do lll=1,3
7963               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7964               call matvec2(auxmat(1,1),b1(1,iti),
7965      &          AEAb1derx(1,lll,kkk,iii,1,1))
7966               call matvec2(auxmat(1,1),Ub2(1,i),
7967      &          AEAb2derx(1,lll,kkk,iii,1,1))
7968               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7969      &          AEAb1derx(1,lll,kkk,iii,2,1))
7970               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7971      &          AEAb2derx(1,lll,kkk,iii,2,1))
7972               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7973               call matvec2(auxmat(1,1),b1(1,itl),
7974      &          AEAb1derx(1,lll,kkk,iii,1,2))
7975               call matvec2(auxmat(1,1),Ub2(1,l),
7976      &          AEAb2derx(1,lll,kkk,iii,1,2))
7977               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7978      &          AEAb1derx(1,lll,kkk,iii,2,2))
7979               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7980      &          AEAb2derx(1,lll,kkk,iii,2,2))
7981             enddo
7982           enddo
7983         enddo
7984         ENDIF
7985 C End vectors
7986       endif
7987       return
7988       end
7989 C---------------------------------------------------------------------------
7990       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7991      &  KK,KKderg,AKA,AKAderg,AKAderx)
7992       implicit none
7993       integer nderg
7994       logical transp
7995       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7996      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7997      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7998       integer iii,kkk,lll
7999       integer jjj,mmm
8000       logical lprn
8001       common /kutas/ lprn
8002       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8003       do iii=1,nderg
8004         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8005      &    AKAderg(1,1,iii))
8006       enddo
8007 cd      if (lprn) write (2,*) 'In kernel'
8008       do kkk=1,5
8009 cd        if (lprn) write (2,*) 'kkk=',kkk
8010         do lll=1,3
8011           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8012      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8013 cd          if (lprn) then
8014 cd            write (2,*) 'lll=',lll
8015 cd            write (2,*) 'iii=1'
8016 cd            do jjj=1,2
8017 cd              write (2,'(3(2f10.5),5x)')
8018 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8019 cd            enddo
8020 cd          endif
8021           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8022      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8023 cd          if (lprn) then
8024 cd            write (2,*) 'lll=',lll
8025 cd            write (2,*) 'iii=2'
8026 cd            do jjj=1,2
8027 cd              write (2,'(3(2f10.5),5x)')
8028 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8029 cd            enddo
8030 cd          endif
8031         enddo
8032       enddo
8033       return
8034       end
8035 C---------------------------------------------------------------------------
8036       double precision function eello4(i,j,k,l,jj,kk)
8037       implicit real*8 (a-h,o-z)
8038       include 'DIMENSIONS'
8039       include 'COMMON.IOUNITS'
8040       include 'COMMON.CHAIN'
8041       include 'COMMON.DERIV'
8042       include 'COMMON.INTERACT'
8043       include 'COMMON.CONTACTS'
8044       include 'COMMON.TORSION'
8045       include 'COMMON.VAR'
8046       include 'COMMON.GEO'
8047       double precision pizda(2,2),ggg1(3),ggg2(3)
8048 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8049 cd        eello4=0.0d0
8050 cd        return
8051 cd      endif
8052 cd      print *,'eello4:',i,j,k,l,jj,kk
8053 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8054 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8055 cold      eij=facont_hb(jj,i)
8056 cold      ekl=facont_hb(kk,k)
8057 cold      ekont=eij*ekl
8058       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8059 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8060       gcorr_loc(k-1)=gcorr_loc(k-1)
8061      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8062       if (l.eq.j+1) then
8063         gcorr_loc(l-1)=gcorr_loc(l-1)
8064      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8065       else
8066         gcorr_loc(j-1)=gcorr_loc(j-1)
8067      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8068       endif
8069       do iii=1,2
8070         do kkk=1,5
8071           do lll=1,3
8072             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8073      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8074 cd            derx(lll,kkk,iii)=0.0d0
8075           enddo
8076         enddo
8077       enddo
8078 cd      gcorr_loc(l-1)=0.0d0
8079 cd      gcorr_loc(j-1)=0.0d0
8080 cd      gcorr_loc(k-1)=0.0d0
8081 cd      eel4=1.0d0
8082 cd      write (iout,*)'Contacts have occurred for peptide groups',
8083 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8084 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8085       if (j.lt.nres-1) then
8086         j1=j+1
8087         j2=j-1
8088       else
8089         j1=j-1
8090         j2=j-2
8091       endif
8092       if (l.lt.nres-1) then
8093         l1=l+1
8094         l2=l-1
8095       else
8096         l1=l-1
8097         l2=l-2
8098       endif
8099       do ll=1,3
8100 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8101 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8102         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8103         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8104 cgrad        ghalf=0.5d0*ggg1(ll)
8105         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8106         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8107         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8108         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8109         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8110         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8111 cgrad        ghalf=0.5d0*ggg2(ll)
8112         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8113         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8114         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8115         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8116         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8117         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8118       enddo
8119 cgrad      do m=i+1,j-1
8120 cgrad        do ll=1,3
8121 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8122 cgrad        enddo
8123 cgrad      enddo
8124 cgrad      do m=k+1,l-1
8125 cgrad        do ll=1,3
8126 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8127 cgrad        enddo
8128 cgrad      enddo
8129 cgrad      do m=i+2,j2
8130 cgrad        do ll=1,3
8131 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8132 cgrad        enddo
8133 cgrad      enddo
8134 cgrad      do m=k+2,l2
8135 cgrad        do ll=1,3
8136 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8137 cgrad        enddo
8138 cgrad      enddo
8139 cd      do iii=1,nres-3
8140 cd        write (2,*) iii,gcorr_loc(iii)
8141 cd      enddo
8142       eello4=ekont*eel4
8143 cd      write (2,*) 'ekont',ekont
8144 cd      write (iout,*) 'eello4',ekont*eel4
8145       return
8146       end
8147 C---------------------------------------------------------------------------
8148       double precision function eello5(i,j,k,l,jj,kk)
8149       implicit real*8 (a-h,o-z)
8150       include 'DIMENSIONS'
8151       include 'COMMON.IOUNITS'
8152       include 'COMMON.CHAIN'
8153       include 'COMMON.DERIV'
8154       include 'COMMON.INTERACT'
8155       include 'COMMON.CONTACTS'
8156       include 'COMMON.TORSION'
8157       include 'COMMON.VAR'
8158       include 'COMMON.GEO'
8159       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8160       double precision ggg1(3),ggg2(3)
8161 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8162 C                                                                              C
8163 C                            Parallel chains                                   C
8164 C                                                                              C
8165 C          o             o                   o             o                   C
8166 C         /l\           / \             \   / \           / \   /              C
8167 C        /   \         /   \             \ /   \         /   \ /               C
8168 C       j| o |l1       | o |              o| o |         | o |o                C
8169 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8170 C      \i/   \         /   \ /             /   \         /   \                 C
8171 C       o    k1             o                                                  C
8172 C         (I)          (II)                (III)          (IV)                 C
8173 C                                                                              C
8174 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8175 C                                                                              C
8176 C                            Antiparallel chains                               C
8177 C                                                                              C
8178 C          o             o                   o             o                   C
8179 C         /j\           / \             \   / \           / \   /              C
8180 C        /   \         /   \             \ /   \         /   \ /               C
8181 C      j1| o |l        | o |              o| o |         | o |o                C
8182 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8183 C      \i/   \         /   \ /             /   \         /   \                 C
8184 C       o     k1            o                                                  C
8185 C         (I)          (II)                (III)          (IV)                 C
8186 C                                                                              C
8187 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8188 C                                                                              C
8189 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8190 C                                                                              C
8191 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8192 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8193 cd        eello5=0.0d0
8194 cd        return
8195 cd      endif
8196 cd      write (iout,*)
8197 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8198 cd     &   ' and',k,l
8199       itk=itortyp(itype(k))
8200       itl=itortyp(itype(l))
8201       itj=itortyp(itype(j))
8202       eello5_1=0.0d0
8203       eello5_2=0.0d0
8204       eello5_3=0.0d0
8205       eello5_4=0.0d0
8206 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8207 cd     &   eel5_3_num,eel5_4_num)
8208       do iii=1,2
8209         do kkk=1,5
8210           do lll=1,3
8211             derx(lll,kkk,iii)=0.0d0
8212           enddo
8213         enddo
8214       enddo
8215 cd      eij=facont_hb(jj,i)
8216 cd      ekl=facont_hb(kk,k)
8217 cd      ekont=eij*ekl
8218 cd      write (iout,*)'Contacts have occurred for peptide groups',
8219 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8220 cd      goto 1111
8221 C Contribution from the graph I.
8222 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8223 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8224       call transpose2(EUg(1,1,k),auxmat(1,1))
8225       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8226       vv(1)=pizda(1,1)-pizda(2,2)
8227       vv(2)=pizda(1,2)+pizda(2,1)
8228       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8229      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8230 C Explicit gradient in virtual-dihedral angles.
8231       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8232      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8233      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8234       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8235       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8236       vv(1)=pizda(1,1)-pizda(2,2)
8237       vv(2)=pizda(1,2)+pizda(2,1)
8238       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8239      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8240      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8241       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8242       vv(1)=pizda(1,1)-pizda(2,2)
8243       vv(2)=pizda(1,2)+pizda(2,1)
8244       if (l.eq.j+1) then
8245         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8246      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8247      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8248       else
8249         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8250      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8251      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8252       endif
8253 C Cartesian gradient
8254       do iii=1,2
8255         do kkk=1,5
8256           do lll=1,3
8257             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8258      &        pizda(1,1))
8259             vv(1)=pizda(1,1)-pizda(2,2)
8260             vv(2)=pizda(1,2)+pizda(2,1)
8261             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8262      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8263      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8264           enddo
8265         enddo
8266       enddo
8267 c      goto 1112
8268 c1111  continue
8269 C Contribution from graph II
8270       call transpose2(EE(1,1,itk),auxmat(1,1))
8271       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8272       vv(1)=pizda(1,1)+pizda(2,2)
8273       vv(2)=pizda(2,1)-pizda(1,2)
8274       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
8275      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8276 C Explicit gradient in virtual-dihedral angles.
8277       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8278      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8279       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8280       vv(1)=pizda(1,1)+pizda(2,2)
8281       vv(2)=pizda(2,1)-pizda(1,2)
8282       if (l.eq.j+1) then
8283         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8284      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8285      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8286       else
8287         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8288      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
8289      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8290       endif
8291 C Cartesian gradient
8292       do iii=1,2
8293         do kkk=1,5
8294           do lll=1,3
8295             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8296      &        pizda(1,1))
8297             vv(1)=pizda(1,1)+pizda(2,2)
8298             vv(2)=pizda(2,1)-pizda(1,2)
8299             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8300      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
8301      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8302           enddo
8303         enddo
8304       enddo
8305 cd      goto 1112
8306 cd1111  continue
8307       if (l.eq.j+1) then
8308 cd        goto 1110
8309 C Parallel orientation
8310 C Contribution from graph III
8311         call transpose2(EUg(1,1,l),auxmat(1,1))
8312         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8313         vv(1)=pizda(1,1)-pizda(2,2)
8314         vv(2)=pizda(1,2)+pizda(2,1)
8315         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8316      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8317 C Explicit gradient in virtual-dihedral angles.
8318         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8319      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8320      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8321         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8322         vv(1)=pizda(1,1)-pizda(2,2)
8323         vv(2)=pizda(1,2)+pizda(2,1)
8324         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8325      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8326      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8327         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8328         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8329         vv(1)=pizda(1,1)-pizda(2,2)
8330         vv(2)=pizda(1,2)+pizda(2,1)
8331         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8332      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8333      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8334 C Cartesian gradient
8335         do iii=1,2
8336           do kkk=1,5
8337             do lll=1,3
8338               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8339      &          pizda(1,1))
8340               vv(1)=pizda(1,1)-pizda(2,2)
8341               vv(2)=pizda(1,2)+pizda(2,1)
8342               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8343      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8344      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8345             enddo
8346           enddo
8347         enddo
8348 cd        goto 1112
8349 C Contribution from graph IV
8350 cd1110    continue
8351         call transpose2(EE(1,1,itl),auxmat(1,1))
8352         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8353         vv(1)=pizda(1,1)+pizda(2,2)
8354         vv(2)=pizda(2,1)-pizda(1,2)
8355         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
8356      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8357 C Explicit gradient in virtual-dihedral angles.
8358         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8359      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8360         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8361         vv(1)=pizda(1,1)+pizda(2,2)
8362         vv(2)=pizda(2,1)-pizda(1,2)
8363         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8364      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
8365      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8366 C Cartesian gradient
8367         do iii=1,2
8368           do kkk=1,5
8369             do lll=1,3
8370               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8371      &          pizda(1,1))
8372               vv(1)=pizda(1,1)+pizda(2,2)
8373               vv(2)=pizda(2,1)-pizda(1,2)
8374               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8375      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
8376      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8377             enddo
8378           enddo
8379         enddo
8380       else
8381 C Antiparallel orientation
8382 C Contribution from graph III
8383 c        goto 1110
8384         call transpose2(EUg(1,1,j),auxmat(1,1))
8385         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8386         vv(1)=pizda(1,1)-pizda(2,2)
8387         vv(2)=pizda(1,2)+pizda(2,1)
8388         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
8389      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8390 C Explicit gradient in virtual-dihedral angles.
8391         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8392      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
8393      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8394         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8395         vv(1)=pizda(1,1)-pizda(2,2)
8396         vv(2)=pizda(1,2)+pizda(2,1)
8397         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8398      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
8399      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8400         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8401         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8402         vv(1)=pizda(1,1)-pizda(2,2)
8403         vv(2)=pizda(1,2)+pizda(2,1)
8404         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8405      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
8406      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8407 C Cartesian gradient
8408         do iii=1,2
8409           do kkk=1,5
8410             do lll=1,3
8411               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8412      &          pizda(1,1))
8413               vv(1)=pizda(1,1)-pizda(2,2)
8414               vv(2)=pizda(1,2)+pizda(2,1)
8415               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8416      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
8417      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8418             enddo
8419           enddo
8420         enddo
8421 cd        goto 1112
8422 C Contribution from graph IV
8423 1110    continue
8424         call transpose2(EE(1,1,itj),auxmat(1,1))
8425         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8426         vv(1)=pizda(1,1)+pizda(2,2)
8427         vv(2)=pizda(2,1)-pizda(1,2)
8428         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
8429      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
8430 C Explicit gradient in virtual-dihedral angles.
8431         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8432      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
8433         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8434         vv(1)=pizda(1,1)+pizda(2,2)
8435         vv(2)=pizda(2,1)-pizda(1,2)
8436         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8437      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
8438      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
8439 C Cartesian gradient
8440         do iii=1,2
8441           do kkk=1,5
8442             do lll=1,3
8443               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8444      &          pizda(1,1))
8445               vv(1)=pizda(1,1)+pizda(2,2)
8446               vv(2)=pizda(2,1)-pizda(1,2)
8447               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
8448      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
8449      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
8450             enddo
8451           enddo
8452         enddo
8453       endif
8454 1112  continue
8455       eel5=eello5_1+eello5_2+eello5_3+eello5_4
8456 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
8457 cd        write (2,*) 'ijkl',i,j,k,l
8458 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
8459 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
8460 cd      endif
8461 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
8462 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
8463 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
8464 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
8465       if (j.lt.nres-1) then
8466         j1=j+1
8467         j2=j-1
8468       else
8469         j1=j-1
8470         j2=j-2
8471       endif
8472       if (l.lt.nres-1) then
8473         l1=l+1
8474         l2=l-1
8475       else
8476         l1=l-1
8477         l2=l-2
8478       endif
8479 cd      eij=1.0d0
8480 cd      ekl=1.0d0
8481 cd      ekont=1.0d0
8482 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
8483 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
8484 C        summed up outside the subrouine as for the other subroutines
8485 C        handling long-range interactions. The old code is commented out
8486 C        with "cgrad" to keep track of changes.
8487       do ll=1,3
8488 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
8489 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
8490         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
8491         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
8492 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
8493 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
8494 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
8495 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
8496 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
8497 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
8498 c     &   gradcorr5ij,
8499 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
8500 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
8501 cgrad        ghalf=0.5d0*ggg1(ll)
8502 cd        ghalf=0.0d0
8503         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
8504         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
8505         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
8506         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
8507         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
8508         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
8509 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
8510 cgrad        ghalf=0.5d0*ggg2(ll)
8511 cd        ghalf=0.0d0
8512         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
8513         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
8514         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
8515         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
8516         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
8517         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
8518       enddo
8519 cd      goto 1112
8520 cgrad      do m=i+1,j-1
8521 cgrad        do ll=1,3
8522 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
8523 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
8524 cgrad        enddo
8525 cgrad      enddo
8526 cgrad      do m=k+1,l-1
8527 cgrad        do ll=1,3
8528 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
8529 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8530 cgrad        enddo
8531 cgrad      enddo
8532 c1112  continue
8533 cgrad      do m=i+2,j2
8534 cgrad        do ll=1,3
8535 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8536 cgrad        enddo
8537 cgrad      enddo
8538 cgrad      do m=k+2,l2
8539 cgrad        do ll=1,3
8540 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8541 cgrad        enddo
8542 cgrad      enddo
8543 cd      do iii=1,nres-3
8544 cd        write (2,*) iii,g_corr5_loc(iii)
8545 cd      enddo
8546       eello5=ekont*eel5
8547 cd      write (2,*) 'ekont',ekont
8548 cd      write (iout,*) 'eello5',ekont*eel5
8549       return
8550       end
8551 c--------------------------------------------------------------------------
8552       double precision function eello6(i,j,k,l,jj,kk)
8553       implicit real*8 (a-h,o-z)
8554       include 'DIMENSIONS'
8555       include 'COMMON.IOUNITS'
8556       include 'COMMON.CHAIN'
8557       include 'COMMON.DERIV'
8558       include 'COMMON.INTERACT'
8559       include 'COMMON.CONTACTS'
8560       include 'COMMON.TORSION'
8561       include 'COMMON.VAR'
8562       include 'COMMON.GEO'
8563       include 'COMMON.FFIELD'
8564       double precision ggg1(3),ggg2(3)
8565 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8566 cd        eello6=0.0d0
8567 cd        return
8568 cd      endif
8569 cd      write (iout,*)
8570 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8571 cd     &   ' and',k,l
8572       eello6_1=0.0d0
8573       eello6_2=0.0d0
8574       eello6_3=0.0d0
8575       eello6_4=0.0d0
8576       eello6_5=0.0d0
8577       eello6_6=0.0d0
8578 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8579 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8580       do iii=1,2
8581         do kkk=1,5
8582           do lll=1,3
8583             derx(lll,kkk,iii)=0.0d0
8584           enddo
8585         enddo
8586       enddo
8587 cd      eij=facont_hb(jj,i)
8588 cd      ekl=facont_hb(kk,k)
8589 cd      ekont=eij*ekl
8590 cd      eij=1.0d0
8591 cd      ekl=1.0d0
8592 cd      ekont=1.0d0
8593       if (l.eq.j+1) then
8594         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8595         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8596         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8597         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8598         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8599         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8600       else
8601         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8602         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8603         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8604         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8605         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8606           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8607         else
8608           eello6_5=0.0d0
8609         endif
8610         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8611       endif
8612 C If turn contributions are considered, they will be handled separately.
8613       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8614 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8615 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8616 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8617 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8618 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8619 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8620 cd      goto 1112
8621       if (j.lt.nres-1) then
8622         j1=j+1
8623         j2=j-1
8624       else
8625         j1=j-1
8626         j2=j-2
8627       endif
8628       if (l.lt.nres-1) then
8629         l1=l+1
8630         l2=l-1
8631       else
8632         l1=l-1
8633         l2=l-2
8634       endif
8635       do ll=1,3
8636 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8637 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8638 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8639 cgrad        ghalf=0.5d0*ggg1(ll)
8640 cd        ghalf=0.0d0
8641         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8642         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8643         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8644         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8645         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8646         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8647         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8648         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8649 cgrad        ghalf=0.5d0*ggg2(ll)
8650 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8651 cd        ghalf=0.0d0
8652         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8653         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8654         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8655         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8656         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8657         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8658       enddo
8659 cd      goto 1112
8660 cgrad      do m=i+1,j-1
8661 cgrad        do ll=1,3
8662 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8663 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8664 cgrad        enddo
8665 cgrad      enddo
8666 cgrad      do m=k+1,l-1
8667 cgrad        do ll=1,3
8668 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8669 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8670 cgrad        enddo
8671 cgrad      enddo
8672 cgrad1112  continue
8673 cgrad      do m=i+2,j2
8674 cgrad        do ll=1,3
8675 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8676 cgrad        enddo
8677 cgrad      enddo
8678 cgrad      do m=k+2,l2
8679 cgrad        do ll=1,3
8680 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8681 cgrad        enddo
8682 cgrad      enddo
8683 cd      do iii=1,nres-3
8684 cd        write (2,*) iii,g_corr6_loc(iii)
8685 cd      enddo
8686       eello6=ekont*eel6
8687 cd      write (2,*) 'ekont',ekont
8688 cd      write (iout,*) 'eello6',ekont*eel6
8689       return
8690       end
8691 c--------------------------------------------------------------------------
8692       double precision function eello6_graph1(i,j,k,l,imat,swap)
8693       implicit real*8 (a-h,o-z)
8694       include 'DIMENSIONS'
8695       include 'COMMON.IOUNITS'
8696       include 'COMMON.CHAIN'
8697       include 'COMMON.DERIV'
8698       include 'COMMON.INTERACT'
8699       include 'COMMON.CONTACTS'
8700       include 'COMMON.TORSION'
8701       include 'COMMON.VAR'
8702       include 'COMMON.GEO'
8703       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8704       logical swap
8705       logical lprn
8706       common /kutas/ lprn
8707 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8708 C
8709 C      Parallel       Antiparallel
8710 C
8711 C          o             o
8712 C         /l\           /j\
8713 C        /   \         /   \
8714 C       /| o |         | o |\
8715 C     \ j|/k\|  /   \  |/k\|l /
8716 C      \ /   \ /     \ /   \ /
8717 C       o     o       o     o
8718 C       i             i
8719 C
8720 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8721       itk=itortyp(itype(k))
8722       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8723       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8724       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8725       call transpose2(EUgC(1,1,k),auxmat(1,1))
8726       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8727       vv1(1)=pizda1(1,1)-pizda1(2,2)
8728       vv1(2)=pizda1(1,2)+pizda1(2,1)
8729       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8730       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8731       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8732       s5=scalar2(vv(1),Dtobr2(1,i))
8733 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8734       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8735       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8736      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8737      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8738      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8739      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8740      & +scalar2(vv(1),Dtobr2der(1,i)))
8741       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8742       vv1(1)=pizda1(1,1)-pizda1(2,2)
8743       vv1(2)=pizda1(1,2)+pizda1(2,1)
8744       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8745       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8746       if (l.eq.j+1) then
8747         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8748      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8749      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8750      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8751      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8752       else
8753         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8754      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8755      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8756      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8757      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8758       endif
8759       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8760       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8761       vv1(1)=pizda1(1,1)-pizda1(2,2)
8762       vv1(2)=pizda1(1,2)+pizda1(2,1)
8763       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8764      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8765      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8766      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8767       do iii=1,2
8768         if (swap) then
8769           ind=3-iii
8770         else
8771           ind=iii
8772         endif
8773         do kkk=1,5
8774           do lll=1,3
8775             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8776             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8777             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8778             call transpose2(EUgC(1,1,k),auxmat(1,1))
8779             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8780      &        pizda1(1,1))
8781             vv1(1)=pizda1(1,1)-pizda1(2,2)
8782             vv1(2)=pizda1(1,2)+pizda1(2,1)
8783             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8784             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8785      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8786             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8787      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8788             s5=scalar2(vv(1),Dtobr2(1,i))
8789             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8790           enddo
8791         enddo
8792       enddo
8793       return
8794       end
8795 c----------------------------------------------------------------------------
8796       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8797       implicit real*8 (a-h,o-z)
8798       include 'DIMENSIONS'
8799       include 'COMMON.IOUNITS'
8800       include 'COMMON.CHAIN'
8801       include 'COMMON.DERIV'
8802       include 'COMMON.INTERACT'
8803       include 'COMMON.CONTACTS'
8804       include 'COMMON.TORSION'
8805       include 'COMMON.VAR'
8806       include 'COMMON.GEO'
8807       logical swap
8808       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8809      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8810       logical lprn
8811       common /kutas/ lprn
8812 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8813 C                                                                              C
8814 C      Parallel       Antiparallel                                             C
8815 C                                                                              C
8816 C          o             o                                                     C
8817 C     \   /l\           /j\   /                                                C
8818 C      \ /   \         /   \ /                                                 C
8819 C       o| o |         | o |o                                                  C
8820 C     \ j|/k\|      \  |/k\|l                                                  C
8821 C      \ /   \       \ /   \                                                   C
8822 C       o             o                                                        C
8823 C       i             i                                                        C
8824 C                                                                              C
8825 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8826 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8827 C AL 7/4/01 s1 would occur in the sixth-order moment,
8828 C           but not in a cluster cumulant
8829 #ifdef MOMENT
8830       s1=dip(1,jj,i)*dip(1,kk,k)
8831 #endif
8832       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8833       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8834       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8835       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8836       call transpose2(EUg(1,1,k),auxmat(1,1))
8837       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8838       vv(1)=pizda(1,1)-pizda(2,2)
8839       vv(2)=pizda(1,2)+pizda(2,1)
8840       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8841 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8842 #ifdef MOMENT
8843       eello6_graph2=-(s1+s2+s3+s4)
8844 #else
8845       eello6_graph2=-(s2+s3+s4)
8846 #endif
8847 c      eello6_graph2=-s3
8848 C Derivatives in gamma(i-1)
8849       if (i.gt.1) then
8850 #ifdef MOMENT
8851         s1=dipderg(1,jj,i)*dip(1,kk,k)
8852 #endif
8853         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8854         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8855         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8856         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8857 #ifdef MOMENT
8858         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8859 #else
8860         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8861 #endif
8862 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8863       endif
8864 C Derivatives in gamma(k-1)
8865 #ifdef MOMENT
8866       s1=dip(1,jj,i)*dipderg(1,kk,k)
8867 #endif
8868       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8869       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8870       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8871       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8872       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8873       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8874       vv(1)=pizda(1,1)-pizda(2,2)
8875       vv(2)=pizda(1,2)+pizda(2,1)
8876       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8877 #ifdef MOMENT
8878       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8879 #else
8880       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8881 #endif
8882 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8883 C Derivatives in gamma(j-1) or gamma(l-1)
8884       if (j.gt.1) then
8885 #ifdef MOMENT
8886         s1=dipderg(3,jj,i)*dip(1,kk,k)
8887 #endif
8888         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8889         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8890         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8891         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8892         vv(1)=pizda(1,1)-pizda(2,2)
8893         vv(2)=pizda(1,2)+pizda(2,1)
8894         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8895 #ifdef MOMENT
8896         if (swap) then
8897           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8898         else
8899           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8900         endif
8901 #endif
8902         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8903 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8904       endif
8905 C Derivatives in gamma(l-1) or gamma(j-1)
8906       if (l.gt.1) then
8907 #ifdef MOMENT
8908         s1=dip(1,jj,i)*dipderg(3,kk,k)
8909 #endif
8910         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8911         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8912         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8913         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8914         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8915         vv(1)=pizda(1,1)-pizda(2,2)
8916         vv(2)=pizda(1,2)+pizda(2,1)
8917         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8918 #ifdef MOMENT
8919         if (swap) then
8920           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8921         else
8922           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8923         endif
8924 #endif
8925         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8926 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8927       endif
8928 C Cartesian derivatives.
8929       if (lprn) then
8930         write (2,*) 'In eello6_graph2'
8931         do iii=1,2
8932           write (2,*) 'iii=',iii
8933           do kkk=1,5
8934             write (2,*) 'kkk=',kkk
8935             do jjj=1,2
8936               write (2,'(3(2f10.5),5x)')
8937      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8938             enddo
8939           enddo
8940         enddo
8941       endif
8942       do iii=1,2
8943         do kkk=1,5
8944           do lll=1,3
8945 #ifdef MOMENT
8946             if (iii.eq.1) then
8947               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8948             else
8949               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8950             endif
8951 #endif
8952             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8953      &        auxvec(1))
8954             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8955             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8956      &        auxvec(1))
8957             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8958             call transpose2(EUg(1,1,k),auxmat(1,1))
8959             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8960      &        pizda(1,1))
8961             vv(1)=pizda(1,1)-pizda(2,2)
8962             vv(2)=pizda(1,2)+pizda(2,1)
8963             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8964 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8965 #ifdef MOMENT
8966             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8967 #else
8968             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8969 #endif
8970             if (swap) then
8971               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8972             else
8973               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8974             endif
8975           enddo
8976         enddo
8977       enddo
8978       return
8979       end
8980 c----------------------------------------------------------------------------
8981       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8982       implicit real*8 (a-h,o-z)
8983       include 'DIMENSIONS'
8984       include 'COMMON.IOUNITS'
8985       include 'COMMON.CHAIN'
8986       include 'COMMON.DERIV'
8987       include 'COMMON.INTERACT'
8988       include 'COMMON.CONTACTS'
8989       include 'COMMON.TORSION'
8990       include 'COMMON.VAR'
8991       include 'COMMON.GEO'
8992       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8993       logical swap
8994 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8995 C                                                                              C
8996 C      Parallel       Antiparallel                                             C
8997 C                                                                              C
8998 C          o             o                                                     C
8999 C         /l\   /   \   /j\                                                    C
9000 C        /   \ /     \ /   \                                                   C
9001 C       /| o |o       o| o |\                                                  C
9002 C       j|/k\|  /      |/k\|l /                                                C
9003 C        /   \ /       /   \ /                                                 C
9004 C       /     o       /     o                                                  C
9005 C       i             i                                                        C
9006 C                                                                              C
9007 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9008 C
9009 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9010 C           energy moment and not to the cluster cumulant.
9011       iti=itortyp(itype(i))
9012       if (j.lt.nres-1) then
9013         itj1=itortyp(itype(j+1))
9014       else
9015         itj1=ntortyp+1
9016       endif
9017       itk=itortyp(itype(k))
9018       itk1=itortyp(itype(k+1))
9019       if (l.lt.nres-1) then
9020         itl1=itortyp(itype(l+1))
9021       else
9022         itl1=ntortyp+1
9023       endif
9024 #ifdef MOMENT
9025       s1=dip(4,jj,i)*dip(4,kk,k)
9026 #endif
9027       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9028       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9029       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9030       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9031       call transpose2(EE(1,1,itk),auxmat(1,1))
9032       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9033       vv(1)=pizda(1,1)+pizda(2,2)
9034       vv(2)=pizda(2,1)-pizda(1,2)
9035       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9036 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9037 cd     & "sum",-(s2+s3+s4)
9038 #ifdef MOMENT
9039       eello6_graph3=-(s1+s2+s3+s4)
9040 #else
9041       eello6_graph3=-(s2+s3+s4)
9042 #endif
9043 c      eello6_graph3=-s4
9044 C Derivatives in gamma(k-1)
9045       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9046       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9047       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9048       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9049 C Derivatives in gamma(l-1)
9050       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9051       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9052       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9053       vv(1)=pizda(1,1)+pizda(2,2)
9054       vv(2)=pizda(2,1)-pizda(1,2)
9055       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9056       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9057 C Cartesian derivatives.
9058       do iii=1,2
9059         do kkk=1,5
9060           do lll=1,3
9061 #ifdef MOMENT
9062             if (iii.eq.1) then
9063               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9064             else
9065               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9066             endif
9067 #endif
9068             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
9069      &        auxvec(1))
9070             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9071             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
9072      &        auxvec(1))
9073             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9074             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9075      &        pizda(1,1))
9076             vv(1)=pizda(1,1)+pizda(2,2)
9077             vv(2)=pizda(2,1)-pizda(1,2)
9078             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9079 #ifdef MOMENT
9080             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9081 #else
9082             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9083 #endif
9084             if (swap) then
9085               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9086             else
9087               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9088             endif
9089 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9090           enddo
9091         enddo
9092       enddo
9093       return
9094       end
9095 c----------------------------------------------------------------------------
9096       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9097       implicit real*8 (a-h,o-z)
9098       include 'DIMENSIONS'
9099       include 'COMMON.IOUNITS'
9100       include 'COMMON.CHAIN'
9101       include 'COMMON.DERIV'
9102       include 'COMMON.INTERACT'
9103       include 'COMMON.CONTACTS'
9104       include 'COMMON.TORSION'
9105       include 'COMMON.VAR'
9106       include 'COMMON.GEO'
9107       include 'COMMON.FFIELD'
9108       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9109      & auxvec1(2),auxmat1(2,2)
9110       logical swap
9111 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9112 C                                                                              C
9113 C      Parallel       Antiparallel                                             C
9114 C                                                                              C
9115 C          o             o                                                     C
9116 C         /l\   /   \   /j\                                                    C
9117 C        /   \ /     \ /   \                                                   C
9118 C       /| o |o       o| o |\                                                  C
9119 C     \ j|/k\|      \  |/k\|l                                                  C
9120 C      \ /   \       \ /   \                                                   C
9121 C       o     \       o     \                                                  C
9122 C       i             i                                                        C
9123 C                                                                              C
9124 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9125 C
9126 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9127 C           energy moment and not to the cluster cumulant.
9128 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9129       iti=itortyp(itype(i))
9130       itj=itortyp(itype(j))
9131       if (j.lt.nres-1) then
9132         itj1=itortyp(itype(j+1))
9133       else
9134         itj1=ntortyp+1
9135       endif
9136       itk=itortyp(itype(k))
9137       if (k.lt.nres-1) then
9138         itk1=itortyp(itype(k+1))
9139       else
9140         itk1=ntortyp+1
9141       endif
9142       itl=itortyp(itype(l))
9143       if (l.lt.nres-1) then
9144         itl1=itortyp(itype(l+1))
9145       else
9146         itl1=ntortyp+1
9147       endif
9148 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9149 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9150 cd     & ' itl',itl,' itl1',itl1
9151 #ifdef MOMENT
9152       if (imat.eq.1) then
9153         s1=dip(3,jj,i)*dip(3,kk,k)
9154       else
9155         s1=dip(2,jj,j)*dip(2,kk,l)
9156       endif
9157 #endif
9158       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9159       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9160       if (j.eq.l+1) then
9161         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9162         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9163       else
9164         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9165         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9166       endif
9167       call transpose2(EUg(1,1,k),auxmat(1,1))
9168       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9169       vv(1)=pizda(1,1)-pizda(2,2)
9170       vv(2)=pizda(2,1)+pizda(1,2)
9171       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9172 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9173 #ifdef MOMENT
9174       eello6_graph4=-(s1+s2+s3+s4)
9175 #else
9176       eello6_graph4=-(s2+s3+s4)
9177 #endif
9178 C Derivatives in gamma(i-1)
9179       if (i.gt.1) then
9180 #ifdef MOMENT
9181         if (imat.eq.1) then
9182           s1=dipderg(2,jj,i)*dip(3,kk,k)
9183         else
9184           s1=dipderg(4,jj,j)*dip(2,kk,l)
9185         endif
9186 #endif
9187         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9188         if (j.eq.l+1) then
9189           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9190           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9191         else
9192           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9193           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9194         endif
9195         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9196         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9197 cd          write (2,*) 'turn6 derivatives'
9198 #ifdef MOMENT
9199           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9200 #else
9201           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9202 #endif
9203         else
9204 #ifdef MOMENT
9205           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9206 #else
9207           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9208 #endif
9209         endif
9210       endif
9211 C Derivatives in gamma(k-1)
9212 #ifdef MOMENT
9213       if (imat.eq.1) then
9214         s1=dip(3,jj,i)*dipderg(2,kk,k)
9215       else
9216         s1=dip(2,jj,j)*dipderg(4,kk,l)
9217       endif
9218 #endif
9219       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9220       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9221       if (j.eq.l+1) then
9222         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9223         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9224       else
9225         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9226         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9227       endif
9228       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9229       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9230       vv(1)=pizda(1,1)-pizda(2,2)
9231       vv(2)=pizda(2,1)+pizda(1,2)
9232       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9233       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9234 #ifdef MOMENT
9235         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9236 #else
9237         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9238 #endif
9239       else
9240 #ifdef MOMENT
9241         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9242 #else
9243         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9244 #endif
9245       endif
9246 C Derivatives in gamma(j-1) or gamma(l-1)
9247       if (l.eq.j+1 .and. l.gt.1) then
9248         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9249         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9250         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9251         vv(1)=pizda(1,1)-pizda(2,2)
9252         vv(2)=pizda(2,1)+pizda(1,2)
9253         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9254         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9255       else if (j.gt.1) then
9256         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9257         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9258         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9259         vv(1)=pizda(1,1)-pizda(2,2)
9260         vv(2)=pizda(2,1)+pizda(1,2)
9261         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9262         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9263           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9264         else
9265           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9266         endif
9267       endif
9268 C Cartesian derivatives.
9269       do iii=1,2
9270         do kkk=1,5
9271           do lll=1,3
9272 #ifdef MOMENT
9273             if (iii.eq.1) then
9274               if (imat.eq.1) then
9275                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9276               else
9277                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9278               endif
9279             else
9280               if (imat.eq.1) then
9281                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9282               else
9283                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9284               endif
9285             endif
9286 #endif
9287             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9288      &        auxvec(1))
9289             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9290             if (j.eq.l+1) then
9291               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9292      &          b1(1,itj1),auxvec(1))
9293               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9294             else
9295               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9296      &          b1(1,itl1),auxvec(1))
9297               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9298             endif
9299             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9300      &        pizda(1,1))
9301             vv(1)=pizda(1,1)-pizda(2,2)
9302             vv(2)=pizda(2,1)+pizda(1,2)
9303             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9304             if (swap) then
9305               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9306 #ifdef MOMENT
9307                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9308      &             -(s1+s2+s4)
9309 #else
9310                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9311      &             -(s2+s4)
9312 #endif
9313                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9314               else
9315 #ifdef MOMENT
9316                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9317 #else
9318                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9319 #endif
9320                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9321               endif
9322             else
9323 #ifdef MOMENT
9324               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9325 #else
9326               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9327 #endif
9328               if (l.eq.j+1) then
9329                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9330               else
9331                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9332               endif
9333             endif
9334           enddo
9335         enddo
9336       enddo
9337       return
9338       end
9339 c----------------------------------------------------------------------------
9340       double precision function eello_turn6(i,jj,kk)
9341       implicit real*8 (a-h,o-z)
9342       include 'DIMENSIONS'
9343       include 'COMMON.IOUNITS'
9344       include 'COMMON.CHAIN'
9345       include 'COMMON.DERIV'
9346       include 'COMMON.INTERACT'
9347       include 'COMMON.CONTACTS'
9348       include 'COMMON.TORSION'
9349       include 'COMMON.VAR'
9350       include 'COMMON.GEO'
9351       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9352      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9353      &  ggg1(3),ggg2(3)
9354       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9355      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9356 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9357 C           the respective energy moment and not to the cluster cumulant.
9358       s1=0.0d0
9359       s8=0.0d0
9360       s13=0.0d0
9361 c
9362       eello_turn6=0.0d0
9363       j=i+4
9364       k=i+1
9365       l=i+3
9366       iti=itortyp(itype(i))
9367       itk=itortyp(itype(k))
9368       itk1=itortyp(itype(k+1))
9369       itl=itortyp(itype(l))
9370       itj=itortyp(itype(j))
9371 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9372 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
9373 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9374 cd        eello6=0.0d0
9375 cd        return
9376 cd      endif
9377 cd      write (iout,*)
9378 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9379 cd     &   ' and',k,l
9380 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
9381       do iii=1,2
9382         do kkk=1,5
9383           do lll=1,3
9384             derx_turn(lll,kkk,iii)=0.0d0
9385           enddo
9386         enddo
9387       enddo
9388 cd      eij=1.0d0
9389 cd      ekl=1.0d0
9390 cd      ekont=1.0d0
9391       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9392 cd      eello6_5=0.0d0
9393 cd      write (2,*) 'eello6_5',eello6_5
9394 #ifdef MOMENT
9395       call transpose2(AEA(1,1,1),auxmat(1,1))
9396       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9397       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9398       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9399 #endif
9400       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9401       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
9402       s2 = scalar2(b1(1,itk),vtemp1(1))
9403 #ifdef MOMENT
9404       call transpose2(AEA(1,1,2),atemp(1,1))
9405       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
9406       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
9407       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9408 #endif
9409       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
9410       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
9411       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
9412 #ifdef MOMENT
9413       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
9414       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
9415       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
9416       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
9417       ss13 = scalar2(b1(1,itk),vtemp4(1))
9418       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
9419 #endif
9420 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
9421 c      s1=0.0d0
9422 c      s2=0.0d0
9423 c      s8=0.0d0
9424 c      s12=0.0d0
9425 c      s13=0.0d0
9426       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
9427 C Derivatives in gamma(i+2)
9428       s1d =0.0d0
9429       s8d =0.0d0
9430 #ifdef MOMENT
9431       call transpose2(AEA(1,1,1),auxmatd(1,1))
9432       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9433       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9434       call transpose2(AEAderg(1,1,2),atempd(1,1))
9435       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9436       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9437 #endif
9438       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
9439       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9440       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9441 c      s1d=0.0d0
9442 c      s2d=0.0d0
9443 c      s8d=0.0d0
9444 c      s12d=0.0d0
9445 c      s13d=0.0d0
9446       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
9447 C Derivatives in gamma(i+3)
9448 #ifdef MOMENT
9449       call transpose2(AEA(1,1,1),auxmatd(1,1))
9450       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9451       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
9452       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
9453 #endif
9454       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
9455       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
9456       s2d = scalar2(b1(1,itk),vtemp1d(1))
9457 #ifdef MOMENT
9458       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
9459       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
9460 #endif
9461       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
9462 #ifdef MOMENT
9463       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
9464       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9465       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9466 #endif
9467 c      s1d=0.0d0
9468 c      s2d=0.0d0
9469 c      s8d=0.0d0
9470 c      s12d=0.0d0
9471 c      s13d=0.0d0
9472 #ifdef MOMENT
9473       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9474      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9475 #else
9476       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
9477      &               -0.5d0*ekont*(s2d+s12d)
9478 #endif
9479 C Derivatives in gamma(i+4)
9480       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
9481       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9482       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9483 #ifdef MOMENT
9484       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
9485       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
9486       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
9487 #endif
9488 c      s1d=0.0d0
9489 c      s2d=0.0d0
9490 c      s8d=0.0d0
9491 C      s12d=0.0d0
9492 c      s13d=0.0d0
9493 #ifdef MOMENT
9494       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
9495 #else
9496       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
9497 #endif
9498 C Derivatives in gamma(i+5)
9499 #ifdef MOMENT
9500       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
9501       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9502       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9503 #endif
9504       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
9505       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
9506       s2d = scalar2(b1(1,itk),vtemp1d(1))
9507 #ifdef MOMENT
9508       call transpose2(AEA(1,1,2),atempd(1,1))
9509       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
9510       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
9511 #endif
9512       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
9513       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9514 #ifdef MOMENT
9515       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
9516       ss13d = scalar2(b1(1,itk),vtemp4d(1))
9517       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9518 #endif
9519 c      s1d=0.0d0
9520 c      s2d=0.0d0
9521 c      s8d=0.0d0
9522 c      s12d=0.0d0
9523 c      s13d=0.0d0
9524 #ifdef MOMENT
9525       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9526      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
9527 #else
9528       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
9529      &               -0.5d0*ekont*(s2d+s12d)
9530 #endif
9531 C Cartesian derivatives
9532       do iii=1,2
9533         do kkk=1,5
9534           do lll=1,3
9535 #ifdef MOMENT
9536             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9537             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9538             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9539 #endif
9540             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9541             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9542      &          vtemp1d(1))
9543             s2d = scalar2(b1(1,itk),vtemp1d(1))
9544 #ifdef MOMENT
9545             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9546             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9547             s8d = -(atempd(1,1)+atempd(2,2))*
9548      &           scalar2(cc(1,1,itl),vtemp2(1))
9549 #endif
9550             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9551      &           auxmatd(1,1))
9552             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9553             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9554 c      s1d=0.0d0
9555 c      s2d=0.0d0
9556 c      s8d=0.0d0
9557 c      s12d=0.0d0
9558 c      s13d=0.0d0
9559 #ifdef MOMENT
9560             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9561      &        - 0.5d0*(s1d+s2d)
9562 #else
9563             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9564      &        - 0.5d0*s2d
9565 #endif
9566 #ifdef MOMENT
9567             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9568      &        - 0.5d0*(s8d+s12d)
9569 #else
9570             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9571      &        - 0.5d0*s12d
9572 #endif
9573           enddo
9574         enddo
9575       enddo
9576 #ifdef MOMENT
9577       do kkk=1,5
9578         do lll=1,3
9579           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9580      &      achuj_tempd(1,1))
9581           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9582           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9583           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9584           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9585           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9586      &      vtemp4d(1))
9587           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9588           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9589           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9590         enddo
9591       enddo
9592 #endif
9593 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9594 cd     &  16*eel_turn6_num
9595 cd      goto 1112
9596       if (j.lt.nres-1) then
9597         j1=j+1
9598         j2=j-1
9599       else
9600         j1=j-1
9601         j2=j-2
9602       endif
9603       if (l.lt.nres-1) then
9604         l1=l+1
9605         l2=l-1
9606       else
9607         l1=l-1
9608         l2=l-2
9609       endif
9610       do ll=1,3
9611 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9612 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9613 cgrad        ghalf=0.5d0*ggg1(ll)
9614 cd        ghalf=0.0d0
9615         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9616         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9617         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9618      &    +ekont*derx_turn(ll,2,1)
9619         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9620         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9621      &    +ekont*derx_turn(ll,4,1)
9622         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9623         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9624         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9625 cgrad        ghalf=0.5d0*ggg2(ll)
9626 cd        ghalf=0.0d0
9627         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9628      &    +ekont*derx_turn(ll,2,2)
9629         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9630         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9631      &    +ekont*derx_turn(ll,4,2)
9632         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9633         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9634         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9635       enddo
9636 cd      goto 1112
9637 cgrad      do m=i+1,j-1
9638 cgrad        do ll=1,3
9639 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9640 cgrad        enddo
9641 cgrad      enddo
9642 cgrad      do m=k+1,l-1
9643 cgrad        do ll=1,3
9644 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9645 cgrad        enddo
9646 cgrad      enddo
9647 cgrad1112  continue
9648 cgrad      do m=i+2,j2
9649 cgrad        do ll=1,3
9650 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9651 cgrad        enddo
9652 cgrad      enddo
9653 cgrad      do m=k+2,l2
9654 cgrad        do ll=1,3
9655 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9656 cgrad        enddo
9657 cgrad      enddo
9658 cd      do iii=1,nres-3
9659 cd        write (2,*) iii,g_corr6_loc(iii)
9660 cd      enddo
9661       eello_turn6=ekont*eel_turn6
9662 cd      write (2,*) 'ekont',ekont
9663 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9664       return
9665       end
9666
9667 C-----------------------------------------------------------------------------
9668       double precision function scalar(u,v)
9669 !DIR$ INLINEALWAYS scalar
9670 #ifndef OSF
9671 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9672 #endif
9673       implicit none
9674       double precision u(3),v(3)
9675 cd      double precision sc
9676 cd      integer i
9677 cd      sc=0.0d0
9678 cd      do i=1,3
9679 cd        sc=sc+u(i)*v(i)
9680 cd      enddo
9681 cd      scalar=sc
9682
9683       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9684       return
9685       end
9686 crc-------------------------------------------------
9687       SUBROUTINE MATVEC2(A1,V1,V2)
9688 !DIR$ INLINEALWAYS MATVEC2
9689 #ifndef OSF
9690 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9691 #endif
9692       implicit real*8 (a-h,o-z)
9693       include 'DIMENSIONS'
9694       DIMENSION A1(2,2),V1(2),V2(2)
9695 c      DO 1 I=1,2
9696 c        VI=0.0
9697 c        DO 3 K=1,2
9698 c    3     VI=VI+A1(I,K)*V1(K)
9699 c        Vaux(I)=VI
9700 c    1 CONTINUE
9701
9702       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9703       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9704
9705       v2(1)=vaux1
9706       v2(2)=vaux2
9707       END
9708 C---------------------------------------
9709       SUBROUTINE MATMAT2(A1,A2,A3)
9710 #ifndef OSF
9711 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9712 #endif
9713       implicit real*8 (a-h,o-z)
9714       include 'DIMENSIONS'
9715       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9716 c      DIMENSION AI3(2,2)
9717 c        DO  J=1,2
9718 c          A3IJ=0.0
9719 c          DO K=1,2
9720 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9721 c          enddo
9722 c          A3(I,J)=A3IJ
9723 c       enddo
9724 c      enddo
9725
9726       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9727       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9728       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9729       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9730
9731       A3(1,1)=AI3_11
9732       A3(2,1)=AI3_21
9733       A3(1,2)=AI3_12
9734       A3(2,2)=AI3_22
9735       END
9736
9737 c-------------------------------------------------------------------------
9738       double precision function scalar2(u,v)
9739 !DIR$ INLINEALWAYS scalar2
9740       implicit none
9741       double precision u(2),v(2)
9742       double precision sc
9743       integer i
9744       scalar2=u(1)*v(1)+u(2)*v(2)
9745       return
9746       end
9747
9748 C-----------------------------------------------------------------------------
9749
9750       subroutine transpose2(a,at)
9751 !DIR$ INLINEALWAYS transpose2
9752 #ifndef OSF
9753 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9754 #endif
9755       implicit none
9756       double precision a(2,2),at(2,2)
9757       at(1,1)=a(1,1)
9758       at(1,2)=a(2,1)
9759       at(2,1)=a(1,2)
9760       at(2,2)=a(2,2)
9761       return
9762       end
9763 c--------------------------------------------------------------------------
9764       subroutine transpose(n,a,at)
9765       implicit none
9766       integer n,i,j
9767       double precision a(n,n),at(n,n)
9768       do i=1,n
9769         do j=1,n
9770           at(j,i)=a(i,j)
9771         enddo
9772       enddo
9773       return
9774       end
9775 C---------------------------------------------------------------------------
9776       subroutine prodmat3(a1,a2,kk,transp,prod)
9777 !DIR$ INLINEALWAYS prodmat3
9778 #ifndef OSF
9779 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9780 #endif
9781       implicit none
9782       integer i,j
9783       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9784       logical transp
9785 crc      double precision auxmat(2,2),prod_(2,2)
9786
9787       if (transp) then
9788 crc        call transpose2(kk(1,1),auxmat(1,1))
9789 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9790 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9791
9792            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9793      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9794            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9795      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9796            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9797      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9798            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9799      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9800
9801       else
9802 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9803 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9804
9805            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9806      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9807            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9808      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9809            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9810      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9811            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9812      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9813
9814       endif
9815 c      call transpose2(a2(1,1),a2t(1,1))
9816
9817 crc      print *,transp
9818 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9819 crc      print *,((prod(i,j),i=1,2),j=1,2)
9820
9821       return
9822       end
9823