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       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 107
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 107
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 107
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 107
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 107
 128 C Soft-sphere potential
 129   106 call e_softsphere(evdw)
 130 C
 131 C Calculate electrostatic (H-bonding) energy of the main chain.
 132 C
 133   107 continue
 134 cmc
 135 cmc Sep-06: egb takes care of dynamic ss bonds too
 136 cmc
 137       if (dyn_ss) call dyn_set_nss
 138
 139 c      print *,"Processor",myrank," computed USCSC"
 140 #ifdef TIMING
 141 #ifdef MPI
 142       time01=MPI_Wtime()
 143 #else
 144       time00=tcpu()
 145 #endif
 146 #endif
 147       call vec_and_deriv
 148 #ifdef TIMING
 149 #ifdef MPI
 150       time_vec=time_vec+MPI_Wtime()-time01
 151 #else
 152       time_vec=time_vec+tcpu()-time01
 153 #endif
 154 #endif
 155 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 156       if (ipot.lt.6) then
 157 #ifdef SPLITELE
 158          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #else
 163          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 164      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 165      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 166      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 167 #endif
 168             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 169          else
 170             ees=0.0d0
 171             evdw1=0.0d0
 172             eel_loc=0.0d0
 173             eello_turn3=0.0d0
 174             eello_turn4=0.0d0
 175          endif
 176       else
 177 c        write (iout,*) "Soft-spheer ELEC potential"
 178         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 179      &   eello_turn4)
 180       endif
 181 c      print *,"Processor",myrank," computed UELEC"
 182 C
 183 C Calculate excluded-volume interaction energy between peptide groups
 184 C and side chains.
 185 C
 186       if (ipot.lt.6) then
 187        if(wscp.gt.0d0) then
 188         call escp(evdw2,evdw2_14)
 189        else
 190         evdw2=0
 191         evdw2_14=0
 192        endif
 193       else
 194 c        write (iout,*) "Soft-sphere SCP potential"
 195         call escp_soft_sphere(evdw2,evdw2_14)
 196       endif
 197 c
 198 c Calculate the bond-stretching energy
 199 c
 200       call ebond(estr)
 201 C
 202 C Calculate the disulfide-bridge and other energy and the contributions
 203 C from other distance constraints.
 204 cd    print *,'Calling EHPB'
 205       call edis(ehpb)
 206 cd    print *,'EHPB exitted succesfully.'
 207 C
 208 C Calculate the virtual-bond-angle energy.
 209 C
 210       if (wang.gt.0d0) then
 211         call ebend(ebe)
 212       else
 213         ebe=0
 214       endif
 215 c      print *,"Processor",myrank," computed UB"
 216 C
 217 C Calculate the SC local energy.
 218 C
 219       call esc(escloc)
 220 c      print *,"Processor",myrank," computed USC"
 221 C
 222 C Calculate the virtual-bond torsional energy.
 223 C
 224 cd    print *,'nterm=',nterm
 225       if (wtor.gt.0) then
 226        call etor(etors,edihcnstr)
 227       else
 228        etors=0
 229        edihcnstr=0
 230       endif
 231 c      print *,"Processor",myrank," computed Utor"
 232 C
 233 C 6/23/01 Calculate double-torsional energy
 234 C
 235       if (wtor_d.gt.0) then
 236        call etor_d(etors_d)
 237       else
 238        etors_d=0
 239       endif
 240 c      print *,"Processor",myrank," computed Utord"
 241 C
 242 C 21/5/07 Calculate local sicdechain correlation energy
 243 C
 244       if (wsccor.gt.0.0d0) then
 245         call eback_sc_corr(esccor)
 246       else
 247         esccor=0.0d0
 248       endif
 249 c      print *,"Processor",myrank," computed Usccorr"
 250 C
 251 C 12/1/95 Multi-body terms
 252 C
 253       n_corr=0
 254       n_corr1=0
 255       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 256      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 257          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 258 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 259 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 260       else
 261          ecorr=0.0d0
 262          ecorr5=0.0d0
 263          ecorr6=0.0d0
 264          eturn6=0.0d0
 265       endif
 266       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 267          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 268 cd         write (iout,*) "multibody_hb ecorr",ecorr
 269       endif
 270 c      print *,"Processor",myrank," computed Ucorr"
 271 C
 272 C If performing constraint dynamics, call the constraint energy
 273 C  after the equilibration time
 274       if(usampl.and.totT.gt.eq_time) then
 275          call EconstrQ
 276          call Econstr_back
 277       else
 278          Uconst=0.0d0
 279          Uconst_back=0.0d0
 280       endif
 281 #ifdef TIMING
 282 #ifdef MPI
 283       time_enecalc=time_enecalc+MPI_Wtime()-time00
 284 #else
 285       time_enecalc=time_enecalc+tcpu()-time00
 286 #endif
 287 #endif
 288 c      print *,"Processor",myrank," computed Uconstr"
 289 #ifdef TIMING
 290 #ifdef MPI
 291       time00=MPI_Wtime()
 292 #else
 293       time00=tcpu()
 294 #endif
 295 #endif
 296 c
 297 C Sum the energies
 298 C
 299       energia(1)=evdw
 300 #ifdef SCP14
 301       energia(2)=evdw2-evdw2_14
 302       energia(18)=evdw2_14
 303 #else
 304       energia(2)=evdw2
 305       energia(18)=0.0d0
 306 #endif
 307 #ifdef SPLITELE
 308       energia(3)=ees
 309       energia(16)=evdw1
 310 #else
 311       energia(3)=ees+evdw1
 312       energia(16)=0.0d0
 313 #endif
 314       energia(4)=ecorr
 315       energia(5)=ecorr5
 316       energia(6)=ecorr6
 317       energia(7)=eel_loc
 318       energia(8)=eello_turn3
 319       energia(9)=eello_turn4
 320       energia(10)=eturn6
 321       energia(11)=ebe
 322       energia(12)=escloc
 323       energia(13)=etors
 324       energia(14)=etors_d
 325       energia(15)=ehpb
 326       energia(19)=edihcnstr
 327       energia(17)=estr
 328       energia(20)=Uconst+Uconst_back
 329       energia(21)=esccor
 330       energia(22)=evdw_p
 331       energia(23)=evdw_m
 332 c      print *," Processor",myrank," calls SUM_ENERGY"
 333       call sum_energy(energia,.true.)
 334 c      print *," Processor",myrank," left SUM_ENERGY"
 335 #ifdef TIMING
 336 #ifdef MPI
 337       time_sumene=time_sumene+MPI_Wtime()-time00
 338 #else
 339       time_sumene=time_sumene+tcpu()-time00
 340 #endif
 341 #endif
 342       return
 343       end
 344 c-------------------------------------------------------------------------------
 345       subroutine sum_energy(energia,reduce)
 346       implicit real*8 (a-h,o-z)
 347       include 'DIMENSIONS'
 348 #ifndef ISNAN
 349       external proc_proc
 350 #ifdef WINPGI
 351 cMS$ATTRIBUTES C ::  proc_proc
 352 #endif
 353 #endif
 354 #ifdef MPI
 355       include "mpif.h"
 356 #endif
 357       include 'COMMON.SETUP'
 358       include 'COMMON.IOUNITS'
 359       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 360       include 'COMMON.FFIELD'
 361       include 'COMMON.DERIV'
 362       include 'COMMON.INTERACT'
 363       include 'COMMON.SBRIDGE'
 364       include 'COMMON.CHAIN'
 365       include 'COMMON.VAR'
 366       include 'COMMON.CONTROL'
 367       include 'COMMON.TIME1'
 368       logical reduce
 369 #ifdef MPI
 370       if (nfgtasks.gt.1 .and. reduce) then
 371 #ifdef DEBUG
 372         write (iout,*) "energies before REDUCE"
 373         call enerprint(energia)
 374         call flush(iout)
 375 #endif
 376         do i=0,n_ene
 377           enebuff(i)=energia(i)
 378         enddo
 379         time00=MPI_Wtime()
 380         call MPI_Barrier(FG_COMM,IERR)
 381         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 382         time00=MPI_Wtime()
 383         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 384      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 385 #ifdef DEBUG
 386         write (iout,*) "energies after REDUCE"
 387         call enerprint(energia)
 388         call flush(iout)
 389 #endif
 390         time_Reduce=time_Reduce+MPI_Wtime()-time00
 391       endif
 392       if (fg_rank.eq.0) then
 393 #endif
 394 #ifdef TSCSC
 395       evdw=energia(22)+wsct*energia(23)
 396 #else
 397       evdw=energia(1)
 398 #endif
 399 #ifdef SCP14
 400       evdw2=energia(2)+energia(18)
 401       evdw2_14=energia(18)
 402 #else
 403       evdw2=energia(2)
 404 #endif
 405 #ifdef SPLITELE
 406       ees=energia(3)
 407       evdw1=energia(16)
 408 #else
 409       ees=energia(3)
 410       evdw1=0.0d0
 411 #endif
 412       ecorr=energia(4)
 413       ecorr5=energia(5)
 414       ecorr6=energia(6)
 415       eel_loc=energia(7)
 416       eello_turn3=energia(8)
 417       eello_turn4=energia(9)
 418       eturn6=energia(10)
 419       ebe=energia(11)
 420       escloc=energia(12)
 421       etors=energia(13)
 422       etors_d=energia(14)
 423       ehpb=energia(15)
 424       edihcnstr=energia(19)
 425       estr=energia(17)
 426       Uconst=energia(20)
 427       esccor=energia(21)
 428 #ifdef SPLITELE
 429       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 430      & +wang*ebe+wtor*etors+wscloc*escloc
 431      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 432      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 433      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 434      & +wbond*estr+Uconst+wsccor*esccor
 435 #else
 436       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 437      & +wang*ebe+wtor*etors+wscloc*escloc
 438      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 439      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 440      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 441      & +wbond*estr+Uconst+wsccor*esccor
 442 #endif
 443       energia(0)=etot
 444 c detecting NaNQ
 445 #ifdef ISNAN
 446 #ifdef AIX
 447       if (isnan(etot).ne.0) energia(0)=1.0d+99
 448 #else
 449       if (isnan(etot)) energia(0)=1.0d+99
 450 #endif
 451 #else
 452       i=0
 453 #ifdef WINPGI
 454       idumm=proc_proc(etot,i)
 455 #else
 456       call proc_proc(etot,i)
 457 #endif
 458       if(i.eq.1)energia(0)=1.0d+99
 459 #endif
 460 #ifdef MPI
 461       endif
 462 #endif
 463       return
 464       end
 465 c-------------------------------------------------------------------------------
 466       subroutine sum_gradient
 467       implicit real*8 (a-h,o-z)
 468       include 'DIMENSIONS'
 469 #ifndef ISNAN
 470       external proc_proc
 471 #ifdef WINPGI
 472 cMS$ATTRIBUTES C ::  proc_proc
 473 #endif
 474 #endif
 475 #ifdef MPI
 476       include 'mpif.h'
 477 #endif
 478       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 479      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 480       include 'COMMON.SETUP'
 481       include 'COMMON.IOUNITS'
 482       include 'COMMON.FFIELD'
 483       include 'COMMON.DERIV'
 484       include 'COMMON.INTERACT'
 485       include 'COMMON.SBRIDGE'
 486       include 'COMMON.CHAIN'
 487       include 'COMMON.VAR'
 488       include 'COMMON.CONTROL'
 489       include 'COMMON.TIME1'
 490       include 'COMMON.MAXGRAD'
 491       include 'COMMON.SCCOR'
 492 #ifdef TIMING
 493 #ifdef MPI
 494       time01=MPI_Wtime()
 495 #else
 496       time01=tcpu()
 497 #endif
 498 #endif
 499 #ifdef DEBUG
 500       write (iout,*) "sum_gradient gvdwc, gvdwx"
 501       do i=1,nres
 502         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 503      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 504      &   (gvdwcT(j,i),j=1,3)
 505       enddo
 506       call flush(iout)
 507 #endif
 508 #ifdef MPI
 509 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 510         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 511      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 512 #endif
 513 C
 514 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 515 C            in virtual-bond-vector coordinates
 516 C
 517 #ifdef DEBUG
 518 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 519 c      do i=1,nres-1
 520 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 521 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 522 c      enddo
 523 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 524 c      do i=1,nres-1
 525 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 526 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 527 c      enddo
 528       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 529       do i=1,nres
 530         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 531      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 532      &   g_corr5_loc(i)
 533       enddo
 534       call flush(iout)
 535 #endif
 536 #ifdef SPLITELE
 537 #ifdef TSCSC
 538       do i=1,nct
 539         do j=1,3
 540           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 541      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 542      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 543      &                wel_loc*gel_loc_long(j,i)+
 544      &                wcorr*gradcorr_long(j,i)+
 545      &                wcorr5*gradcorr5_long(j,i)+
 546      &                wcorr6*gradcorr6_long(j,i)+
 547      &                wturn6*gcorr6_turn_long(j,i)+
 548      &                wstrain*ghpbc(j,i)
 549         enddo
 550       enddo
 551 #else
 552       do i=1,nct
 553         do j=1,3
 554           gradbufc(j,i)=wsc*gvdwc(j,i)+
 555      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 556      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 557      &                wel_loc*gel_loc_long(j,i)+
 558      &                wcorr*gradcorr_long(j,i)+
 559      &                wcorr5*gradcorr5_long(j,i)+
 560      &                wcorr6*gradcorr6_long(j,i)+
 561      &                wturn6*gcorr6_turn_long(j,i)+
 562      &                wstrain*ghpbc(j,i)
 563         enddo
 564       enddo
 565 #endif
 566 #else
 567       do i=1,nct
 568         do j=1,3
 569           gradbufc(j,i)=wsc*gvdwc(j,i)+
 570      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 571      &                welec*gelc_long(j,i)+
 572      &                wbond*gradb(j,i)+
 573      &                wel_loc*gel_loc_long(j,i)+
 574      &                wcorr*gradcorr_long(j,i)+
 575      &                wcorr5*gradcorr5_long(j,i)+
 576      &                wcorr6*gradcorr6_long(j,i)+
 577      &                wturn6*gcorr6_turn_long(j,i)+
 578      &                wstrain*ghpbc(j,i)
 579         enddo
 580       enddo
 581 #endif
 582 #ifdef MPI
 583       if (nfgtasks.gt.1) then
 584       time00=MPI_Wtime()
 585 #ifdef DEBUG
 586       write (iout,*) "gradbufc before allreduce"
 587       do i=1,nres
 588         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 589       enddo
 590       call flush(iout)
 591 #endif
 592       do i=1,nres
 593         do j=1,3
 594           gradbufc_sum(j,i)=gradbufc(j,i)
 595         enddo
 596       enddo
 597 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 598 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 599 c      time_reduce=time_reduce+MPI_Wtime()-time00
 600 #ifdef DEBUG
 601 c      write (iout,*) "gradbufc_sum after allreduce"
 602 c      do i=1,nres
 603 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 604 c      enddo
 605 c      call flush(iout)
 606 #endif
 607 #ifdef TIMING
 608 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 609 #endif
 610       do i=nnt,nres
 611         do k=1,3
 612           gradbufc(k,i)=0.0d0
 613         enddo
 614       enddo
 615 #ifdef DEBUG
 616       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 617       write (iout,*) (i," jgrad_start",jgrad_start(i),
 618      &                  " jgrad_end  ",jgrad_end(i),
 619      &                  i=igrad_start,igrad_end)
 620 #endif
 621 c
 622 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 623 c do not parallelize this part.
 624 c
 625 c      do i=igrad_start,igrad_end
 626 c        do j=jgrad_start(i),jgrad_end(i)
 627 c          do k=1,3
 628 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 629 c          enddo
 630 c        enddo
 631 c      enddo
 632       do j=1,3
 633         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 634       enddo
 635       do i=nres-2,nnt,-1
 636         do j=1,3
 637           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 638         enddo
 639       enddo
 640 #ifdef DEBUG
 641       write (iout,*) "gradbufc after summing"
 642       do i=1,nres
 643         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 644       enddo
 645       call flush(iout)
 646 #endif
 647       else
 648 #endif
 649 #ifdef DEBUG
 650       write (iout,*) "gradbufc"
 651       do i=1,nres
 652         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 653       enddo
 654       call flush(iout)
 655 #endif
 656       do i=1,nres
 657         do j=1,3
 658           gradbufc_sum(j,i)=gradbufc(j,i)
 659           gradbufc(j,i)=0.0d0
 660         enddo
 661       enddo
 662       do j=1,3
 663         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 664       enddo
 665       do i=nres-2,nnt,-1
 666         do j=1,3
 667           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 668         enddo
 669       enddo
 670 c      do i=nnt,nres-1
 671 c        do k=1,3
 672 c          gradbufc(k,i)=0.0d0
 673 c        enddo
 674 c        do j=i+1,nres
 675 c          do k=1,3
 676 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 677 c          enddo
 678 c        enddo
 679 c      enddo
 680 #ifdef DEBUG
 681       write (iout,*) "gradbufc after summing"
 682       do i=1,nres
 683         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 684       enddo
 685       call flush(iout)
 686 #endif
 687 #ifdef MPI
 688       endif
 689 #endif
 690       do k=1,3
 691         gradbufc(k,nres)=0.0d0
 692       enddo
 693       do i=1,nct
 694         do j=1,3
 695 #ifdef SPLITELE
 696           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 697      &                wel_loc*gel_loc(j,i)+
 698      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 699      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 700      &                wel_loc*gel_loc_long(j,i)+
 701      &                wcorr*gradcorr_long(j,i)+
 702      &                wcorr5*gradcorr5_long(j,i)+
 703      &                wcorr6*gradcorr6_long(j,i)+
 704      &                wturn6*gcorr6_turn_long(j,i))+
 705      &                wbond*gradb(j,i)+
 706      &                wcorr*gradcorr(j,i)+
 707      &                wturn3*gcorr3_turn(j,i)+
 708      &                wturn4*gcorr4_turn(j,i)+
 709      &                wcorr5*gradcorr5(j,i)+
 710      &                wcorr6*gradcorr6(j,i)+
 711      &                wturn6*gcorr6_turn(j,i)+
 712      &                wsccor*gsccorc(j,i)
 713      &               +wscloc*gscloc(j,i)
 714 #else
 715           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 716      &                wel_loc*gel_loc(j,i)+
 717      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 718      &                welec*gelc_long(j,i)+
 719      &                wel_loc*gel_loc_long(j,i)+
 720      &                wcorr*gcorr_long(j,i)+
 721      &                wcorr5*gradcorr5_long(j,i)+
 722      &                wcorr6*gradcorr6_long(j,i)+
 723      &                wturn6*gcorr6_turn_long(j,i))+
 724      &                wbond*gradb(j,i)+
 725      &                wcorr*gradcorr(j,i)+
 726      &                wturn3*gcorr3_turn(j,i)+
 727      &                wturn4*gcorr4_turn(j,i)+
 728      &                wcorr5*gradcorr5(j,i)+
 729      &                wcorr6*gradcorr6(j,i)+
 730      &                wturn6*gcorr6_turn(j,i)+
 731      &                wsccor*gsccorc(j,i)
 732      &               +wscloc*gscloc(j,i)
 733 #endif
 734 #ifdef TSCSC
 735           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 736      &                  wscp*gradx_scp(j,i)+
 737      &                  wbond*gradbx(j,i)+
 738      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 739      &                  wsccor*gsccorx(j,i)
 740      &                 +wscloc*gsclocx(j,i)
 741 #else
 742           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 743      &                  wbond*gradbx(j,i)+
 744      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 745      &                  wsccor*gsccorx(j,i)
 746      &                 +wscloc*gsclocx(j,i)
 747 #endif
 748         enddo
 749       enddo
 750 #ifdef DEBUG
 751       write (iout,*) "gloc before adding corr"
 752       do i=1,4*nres
 753         write (iout,*) i,gloc(i,icg)
 754       enddo
 755 #endif
 756       do i=1,nres-3
 757         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 758      &   +wcorr5*g_corr5_loc(i)
 759      &   +wcorr6*g_corr6_loc(i)
 760      &   +wturn4*gel_loc_turn4(i)
 761      &   +wturn3*gel_loc_turn3(i)
 762      &   +wturn6*gel_loc_turn6(i)
 763      &   +wel_loc*gel_loc_loc(i)
 764       enddo
 765 #ifdef DEBUG
 766       write (iout,*) "gloc after adding corr"
 767       do i=1,4*nres
 768         write (iout,*) i,gloc(i,icg)
 769       enddo
 770 #endif
 771 #ifdef MPI
 772       if (nfgtasks.gt.1) then
 773         do j=1,3
 774           do i=1,nres
 775             gradbufc(j,i)=gradc(j,i,icg)
 776             gradbufx(j,i)=gradx(j,i,icg)
 777           enddo
 778         enddo
 779         do i=1,4*nres
 780           glocbuf(i)=gloc(i,icg)
 781         enddo
 782 #ifdef DEBUG
 783       write (iout,*) "gloc_sc before reduce"
 784       do i=1,nres
 785        do j=1,3
 786         write (iout,*) i,j,gloc_sc(j,i,icg)
 787        enddo
 788       enddo
 789 #endif
 790         do i=1,nres
 791          do j=1,3
 792           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 793          enddo
 794         enddo
 795         time00=MPI_Wtime()
 796         call MPI_Barrier(FG_COMM,IERR)
 797         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 798         time00=MPI_Wtime()
 799         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 800      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 801         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 802      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 803         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 804      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 805         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 806      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 807         time_reduce=time_reduce+MPI_Wtime()-time00
 808 #ifdef DEBUG
 809       write (iout,*) "gloc_sc after reduce"
 810       do i=1,nres
 811        do j=1,3
 812         write (iout,*) i,j,gloc_sc(j,i,icg)
 813        enddo
 814       enddo
 815 #endif
 816 #ifdef DEBUG
 817       write (iout,*) "gloc after reduce"
 818       do i=1,4*nres
 819         write (iout,*) i,gloc(i,icg)
 820       enddo
 821 #endif
 822       endif
 823 #endif
 824       if (gnorm_check) then
 825 c
 826 c Compute the maximum elements of the gradient
 827 c
 828       gvdwc_max=0.0d0
 829       gvdwc_scp_max=0.0d0
 830       gelc_max=0.0d0
 831       gvdwpp_max=0.0d0
 832       gradb_max=0.0d0
 833       ghpbc_max=0.0d0
 834       gradcorr_max=0.0d0
 835       gel_loc_max=0.0d0
 836       gcorr3_turn_max=0.0d0
 837       gcorr4_turn_max=0.0d0
 838       gradcorr5_max=0.0d0
 839       gradcorr6_max=0.0d0
 840       gcorr6_turn_max=0.0d0
 841       gsccorc_max=0.0d0
 842       gscloc_max=0.0d0
 843       gvdwx_max=0.0d0
 844       gradx_scp_max=0.0d0
 845       ghpbx_max=0.0d0
 846       gradxorr_max=0.0d0
 847       gsccorx_max=0.0d0
 848       gsclocx_max=0.0d0
 849       do i=1,nct
 850         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 851         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 852 #ifdef TSCSC
 853         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 854         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 855 #endif
 856         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 857         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 858      &   gvdwc_scp_max=gvdwc_scp_norm
 859         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 860         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 861         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 862         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 863         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 864         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 865         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 866         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 867         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 868         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 869         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 870         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 871         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 872      &    gcorr3_turn(1,i)))
 873         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 874      &    gcorr3_turn_max=gcorr3_turn_norm
 875         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 876      &    gcorr4_turn(1,i)))
 877         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 878      &    gcorr4_turn_max=gcorr4_turn_norm
 879         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 880         if (gradcorr5_norm.gt.gradcorr5_max)
 881      &    gradcorr5_max=gradcorr5_norm
 882         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 883         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 884         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 885      &    gcorr6_turn(1,i)))
 886         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 887      &    gcorr6_turn_max=gcorr6_turn_norm
 888         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 889         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 890         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 891         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 892         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 893         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 894 #ifdef TSCSC
 895         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 896         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 897 #endif
 898         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 899         if (gradx_scp_norm.gt.gradx_scp_max)
 900      &    gradx_scp_max=gradx_scp_norm
 901         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 902         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 903         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 904         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 905         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 906         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 907         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 908         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 909       enddo
 910       if (gradout) then
 911 #ifdef AIX
 912         open(istat,file=statname,position="append")
 913 #else
 914         open(istat,file=statname,access="append")
 915 #endif
 916         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 917      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 918      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 919      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 920      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 921      &     gsccorx_max,gsclocx_max
 922         close(istat)
 923         if (gvdwc_max.gt.1.0d4) then
 924           write (iout,*) "gvdwc gvdwx gradb gradbx"
 925           do i=nnt,nct
 926             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 927      &        gradb(j,i),gradbx(j,i),j=1,3)
 928           enddo
 929           call pdbout(0.0d0,'cipiszcze',iout)
 930           call flush(iout)
 931         endif
 932       endif
 933       endif
 934 #ifdef DEBUG
 935       write (iout,*) "gradc gradx gloc"
 936       do i=1,nres
 937         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 938      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 939       enddo
 940 #endif
 941 #ifdef TIMING
 942 #ifdef MPI
 943       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 944 #else
 945       time_sumgradient=time_sumgradient+tcpu()-time01
 946 #endif
 947 #endif
 948       return
 949       end
 950 c-------------------------------------------------------------------------------
 951       subroutine rescale_weights(t_bath)
 952       implicit real*8 (a-h,o-z)
 953       include 'DIMENSIONS'
 954       include 'COMMON.IOUNITS'
 955       include 'COMMON.FFIELD'
 956       include 'COMMON.SBRIDGE'
 957       double precision kfac /2.4d0/
 958       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 959 c      facT=temp0/t_bath
 960 c      facT=2*temp0/(t_bath+temp0)
 961       if (rescale_mode.eq.0) then
 962         facT=1.0d0
 963         facT2=1.0d0
 964         facT3=1.0d0
 965         facT4=1.0d0
 966         facT5=1.0d0
 967       else if (rescale_mode.eq.1) then
 968         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 969         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 970         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 971         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 972         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 973       else if (rescale_mode.eq.2) then
 974         x=t_bath/temp0
 975         x2=x*x
 976         x3=x2*x
 977         x4=x3*x
 978         x5=x4*x
 979         facT=licznik/dlog(dexp(x)+dexp(-x))
 980         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 981         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 982         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 983         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 984       else
 985         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 986         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 987 #ifdef MPI
 988        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 989 #endif
 990        stop 555
 991       endif
 992       welec=weights(3)*fact
 993       wcorr=weights(4)*fact3
 994       wcorr5=weights(5)*fact4
 995       wcorr6=weights(6)*fact5
 996       wel_loc=weights(7)*fact2
 997       wturn3=weights(8)*fact2
 998       wturn4=weights(9)*fact3
 999       wturn6=weights(10)*fact5
1000       wtor=weights(13)*fact
1001       wtor_d=weights(14)*fact2
1002       wsccor=weights(21)*fact
1003 #ifdef TSCSC
1004 c      wsct=t_bath/temp0
1005       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1006 #endif
1007       return
1008       end
1009 C------------------------------------------------------------------------
1010       subroutine enerprint(energia)
1011       implicit real*8 (a-h,o-z)
1012       include 'DIMENSIONS'
1013       include 'COMMON.IOUNITS'
1014       include 'COMMON.FFIELD'
1015       include 'COMMON.SBRIDGE'
1016       include 'COMMON.MD'
1017       double precision energia(0:n_ene)
1018       etot=energia(0)
1019 #ifdef TSCSC
1020       evdw=energia(22)+wsct*energia(23)
1021 #else
1022       evdw=energia(1)
1023 #endif
1024       evdw2=energia(2)
1025 #ifdef SCP14
1026       evdw2=energia(2)+energia(18)
1027 #else
1028       evdw2=energia(2)
1029 #endif
1030       ees=energia(3)
1031 #ifdef SPLITELE
1032       evdw1=energia(16)
1033 #endif
1034       ecorr=energia(4)
1035       ecorr5=energia(5)
1036       ecorr6=energia(6)
1037       eel_loc=energia(7)
1038       eello_turn3=energia(8)
1039       eello_turn4=energia(9)
1040       eello_turn6=energia(10)
1041       ebe=energia(11)
1042       escloc=energia(12)
1043       etors=energia(13)
1044       etors_d=energia(14)
1045       ehpb=energia(15)
1046       edihcnstr=energia(19)
1047       estr=energia(17)
1048       Uconst=energia(20)
1049       esccor=energia(21)
1050 #ifdef SPLITELE
1051       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1052      &  estr,wbond,ebe,wang,
1053      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1054      &  ecorr,wcorr,
1055      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1056      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1057      &  edihcnstr,ebr*nss,
1058      &  Uconst,etot
1059    10 format (/'Virtual-chain energies:'//
1060      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1061      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1062      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1063      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1064      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1065      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1066      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1067      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1068      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1069      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1070      & ' (SS bridges & dist. cnstr.)'/
1071      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1072      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1073      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1074      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1075      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1076      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1077      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1078      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1079      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1080      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1081      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1082      & 'ETOT=  ',1pE16.6,' (total)')
1083 #else
1084       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1085      &  estr,wbond,ebe,wang,
1086      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1087      &  ecorr,wcorr,
1088      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1089      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1090      &  ebr*nss,Uconst,etot
1091    10 format (/'Virtual-chain energies:'//
1092      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1093      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1094      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1095      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1096      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1097      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1098      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1099      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1100      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1101      & ' (SS bridges & dist. cnstr.)'/
1102      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1103      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1105      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1106      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1107      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1108      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1109      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1110      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1111      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1112      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1113      & 'ETOT=  ',1pE16.6,' (total)')
1114 #endif
1115       return
1116       end
1117 C-----------------------------------------------------------------------
1118       subroutine elj(evdw,evdw_p,evdw_m)
1119 C
1120 C This subroutine calculates the interaction energy of nonbonded side chains
1121 C assuming the LJ potential of interaction.
1122 C
1123       implicit real*8 (a-h,o-z)
1124       include 'DIMENSIONS'
1125       parameter (accur=1.0d-10)
1126       include 'COMMON.GEO'
1127       include 'COMMON.VAR'
1128       include 'COMMON.LOCAL'
1129       include 'COMMON.CHAIN'
1130       include 'COMMON.DERIV'
1131       include 'COMMON.INTERACT'
1132       include 'COMMON.TORSION'
1133       include 'COMMON.SBRIDGE'
1134       include 'COMMON.NAMES'
1135       include 'COMMON.IOUNITS'
1136       include 'COMMON.CONTACTS'
1137       dimension gg(3)
1138 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1139       evdw=0.0D0
1140       do i=iatsc_s,iatsc_e
1141         itypi=itype(i)
1142         itypi1=itype(i+1)
1143         xi=c(1,nres+i)
1144         yi=c(2,nres+i)
1145         zi=c(3,nres+i)
1146 C Change 12/1/95
1147         num_conti=0
1148 C
1149 C Calculate SC interaction energy.
1150 C
1151         do iint=1,nint_gr(i)
1152 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1153 cd   &                  'iend=',iend(i,iint)
1154           do j=istart(i,iint),iend(i,iint)
1155             itypj=itype(j)
1156             xj=c(1,nres+j)-xi
1157             yj=c(2,nres+j)-yi
1158             zj=c(3,nres+j)-zi
1159 C Change 12/1/95 to calculate four-body interactions
1160             rij=xj*xj+yj*yj+zj*zj
1161             rrij=1.0D0/rij
1162 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1163             eps0ij=eps(itypi,itypj)
1164             fac=rrij**expon2
1165             e1=fac*fac*aa(itypi,itypj)
1166             e2=fac*bb(itypi,itypj)
1167             evdwij=e1+e2
1168 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1169 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1170 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1171 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1172 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1173 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1174 #ifdef TSCSC
1175             if (bb(itypi,itypj).gt.0) then
1176                evdw_p=evdw_p+evdwij
1177             else
1178                evdw_m=evdw_m+evdwij
1179             endif
1180 #else
1181             evdw=evdw+evdwij
1182 #endif
1183 C
1184 C Calculate the components of the gradient in DC and X
1185 C
1186             fac=-rrij*(e1+evdwij)
1187             gg(1)=xj*fac
1188             gg(2)=yj*fac
1189             gg(3)=zj*fac
1190 #ifdef TSCSC
1191             if (bb(itypi,itypj).gt.0.0d0) then
1192               do k=1,3
1193                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1194                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1195                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1196                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1197               enddo
1198             else
1199               do k=1,3
1200                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1201                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1202                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1203                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1204               enddo
1205             endif
1206 #else
1207             do k=1,3
1208               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1209               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1210               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1211               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1212             enddo
1213 #endif
1214 cgrad            do k=i,j-1
1215 cgrad              do l=1,3
1216 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1217 cgrad              enddo
1218 cgrad            enddo
1219 C
1220 C 12/1/95, revised on 5/20/97
1221 C
1222 C Calculate the contact function. The ith column of the array JCONT will
1223 C contain the numbers of atoms that make contacts with the atom I (of numbers
1224 C greater than I). The arrays FACONT and GACONT will contain the values of
1225 C the contact function and its derivative.
1226 C
1227 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1228 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1229 C Uncomment next line, if the correlation interactions are contact function only
1230             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1231               rij=dsqrt(rij)
1232               sigij=sigma(itypi,itypj)
1233               r0ij=rs0(itypi,itypj)
1234 C
1235 C Check whether the SC's are not too far to make a contact.
1236 C
1237               rcut=1.5d0*r0ij
1238               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1239 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1240 C
1241               if (fcont.gt.0.0D0) then
1242 C If the SC-SC distance if close to sigma, apply spline.
1243 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1244 cAdam &             fcont1,fprimcont1)
1245 cAdam           fcont1=1.0d0-fcont1
1246 cAdam           if (fcont1.gt.0.0d0) then
1247 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1248 cAdam             fcont=fcont*fcont1
1249 cAdam           endif
1250 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1251 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1252 cga             do k=1,3
1253 cga               gg(k)=gg(k)*eps0ij
1254 cga             enddo
1255 cga             eps0ij=-evdwij*eps0ij
1256 C Uncomment for AL's type of SC correlation interactions.
1257 cadam           eps0ij=-evdwij
1258                 num_conti=num_conti+1
1259                 jcont(num_conti,i)=j
1260                 facont(num_conti,i)=fcont*eps0ij
1261                 fprimcont=eps0ij*fprimcont/rij
1262                 fcont=expon*fcont
1263 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1264 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1265 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1266 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1267                 gacont(1,num_conti,i)=-fprimcont*xj
1268                 gacont(2,num_conti,i)=-fprimcont*yj
1269                 gacont(3,num_conti,i)=-fprimcont*zj
1270 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1271 cd              write (iout,'(2i3,3f10.5)')
1272 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1273               endif
1274             endif
1275           enddo      ! j
1276         enddo        ! iint
1277 C Change 12/1/95
1278         num_cont(i)=num_conti
1279       enddo          ! i
1280       do i=1,nct
1281         do j=1,3
1282           gvdwc(j,i)=expon*gvdwc(j,i)
1283           gvdwx(j,i)=expon*gvdwx(j,i)
1284         enddo
1285       enddo
1286 C******************************************************************************
1287 C
1288 C                              N O T E !!!
1289 C
1290 C To save time, the factor of EXPON has been extracted from ALL components
1291 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1292 C use!
1293 C
1294 C******************************************************************************
1295       return
1296       end
1297 C-----------------------------------------------------------------------------
1298       subroutine eljk(evdw,evdw_p,evdw_m)
1299 C
1300 C This subroutine calculates the interaction energy of nonbonded side chains
1301 C assuming the LJK potential of interaction.
1302 C
1303       implicit real*8 (a-h,o-z)
1304       include 'DIMENSIONS'
1305       include 'COMMON.GEO'
1306       include 'COMMON.VAR'
1307       include 'COMMON.LOCAL'
1308       include 'COMMON.CHAIN'
1309       include 'COMMON.DERIV'
1310       include 'COMMON.INTERACT'
1311       include 'COMMON.IOUNITS'
1312       include 'COMMON.NAMES'
1313       dimension gg(3)
1314       logical scheck
1315 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1316       evdw=0.0D0
1317       do i=iatsc_s,iatsc_e
1318         itypi=itype(i)
1319         itypi1=itype(i+1)
1320         xi=c(1,nres+i)
1321         yi=c(2,nres+i)
1322         zi=c(3,nres+i)
1323 C
1324 C Calculate SC interaction energy.
1325 C
1326         do iint=1,nint_gr(i)
1327           do j=istart(i,iint),iend(i,iint)
1328             itypj=itype(j)
1329             xj=c(1,nres+j)-xi
1330             yj=c(2,nres+j)-yi
1331             zj=c(3,nres+j)-zi
1332             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1333             fac_augm=rrij**expon
1334             e_augm=augm(itypi,itypj)*fac_augm
1335             r_inv_ij=dsqrt(rrij)
1336             rij=1.0D0/r_inv_ij
1337             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1338             fac=r_shift_inv**expon
1339             e1=fac*fac*aa(itypi,itypj)
1340             e2=fac*bb(itypi,itypj)
1341             evdwij=e_augm+e1+e2
1342 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1343 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1344 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1345 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1346 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1347 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1348 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1349 #ifdef TSCSC
1350             if (bb(itypi,itypj).gt.0) then
1351                evdw_p=evdw_p+evdwij
1352             else
1353                evdw_m=evdw_m+evdwij
1354             endif
1355 #else
1356             evdw=evdw+evdwij
1357 #endif
1358 C
1359 C Calculate the components of the gradient in DC and X
1360 C
1361             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1362             gg(1)=xj*fac
1363             gg(2)=yj*fac
1364             gg(3)=zj*fac
1365 #ifdef TSCSC
1366             if (bb(itypi,itypj).gt.0.0d0) then
1367               do k=1,3
1368                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1369                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1370                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1371                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1372               enddo
1373             else
1374               do k=1,3
1375                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1376                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1377                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1378                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1379               enddo
1380             endif
1381 #else
1382             do k=1,3
1383               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1384               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1385               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1386               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1387             enddo
1388 #endif
1389 cgrad            do k=i,j-1
1390 cgrad              do l=1,3
1391 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1392 cgrad              enddo
1393 cgrad            enddo
1394           enddo      ! j
1395         enddo        ! iint
1396       enddo          ! i
1397       do i=1,nct
1398         do j=1,3
1399           gvdwc(j,i)=expon*gvdwc(j,i)
1400           gvdwx(j,i)=expon*gvdwx(j,i)
1401         enddo
1402       enddo
1403       return
1404       end
1405 C-----------------------------------------------------------------------------
1406       subroutine ebp(evdw,evdw_p,evdw_m)
1407 C
1408 C This subroutine calculates the interaction energy of nonbonded side chains
1409 C assuming the Berne-Pechukas potential of interaction.
1410 C
1411       implicit real*8 (a-h,o-z)
1412       include 'DIMENSIONS'
1413       include 'COMMON.GEO'
1414       include 'COMMON.VAR'
1415       include 'COMMON.LOCAL'
1416       include 'COMMON.CHAIN'
1417       include 'COMMON.DERIV'
1418       include 'COMMON.NAMES'
1419       include 'COMMON.INTERACT'
1420       include 'COMMON.IOUNITS'
1421       include 'COMMON.CALC'
1422       common /srutu/ icall
1423 c     double precision rrsave(maxdim)
1424       logical lprn
1425       evdw=0.0D0
1426 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1427       evdw=0.0D0
1428 c     if (icall.eq.0) then
1429 c       lprn=.true.
1430 c     else
1431         lprn=.false.
1432 c     endif
1433       ind=0
1434       do i=iatsc_s,iatsc_e
1435         itypi=itype(i)
1436         itypi1=itype(i+1)
1437         xi=c(1,nres+i)
1438         yi=c(2,nres+i)
1439         zi=c(3,nres+i)
1440         dxi=dc_norm(1,nres+i)
1441         dyi=dc_norm(2,nres+i)
1442         dzi=dc_norm(3,nres+i)
1443 c        dsci_inv=dsc_inv(itypi)
1444         dsci_inv=vbld_inv(i+nres)
1445 C
1446 C Calculate SC interaction energy.
1447 C
1448         do iint=1,nint_gr(i)
1449           do j=istart(i,iint),iend(i,iint)
1450             ind=ind+1
1451             itypj=itype(j)
1452 c            dscj_inv=dsc_inv(itypj)
1453             dscj_inv=vbld_inv(j+nres)
1454             chi1=chi(itypi,itypj)
1455             chi2=chi(itypj,itypi)
1456             chi12=chi1*chi2
1457             chip1=chip(itypi)
1458             chip2=chip(itypj)
1459             chip12=chip1*chip2
1460             alf1=alp(itypi)
1461             alf2=alp(itypj)
1462             alf12=0.5D0*(alf1+alf2)
1463 C For diagnostics only!!!
1464 c           chi1=0.0D0
1465 c           chi2=0.0D0
1466 c           chi12=0.0D0
1467 c           chip1=0.0D0
1468 c           chip2=0.0D0
1469 c           chip12=0.0D0
1470 c           alf1=0.0D0
1471 c           alf2=0.0D0
1472 c           alf12=0.0D0
1473             xj=c(1,nres+j)-xi
1474             yj=c(2,nres+j)-yi
1475             zj=c(3,nres+j)-zi
1476             dxj=dc_norm(1,nres+j)
1477             dyj=dc_norm(2,nres+j)
1478             dzj=dc_norm(3,nres+j)
1479             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1480 cd          if (icall.eq.0) then
1481 cd            rrsave(ind)=rrij
1482 cd          else
1483 cd            rrij=rrsave(ind)
1484 cd          endif
1485             rij=dsqrt(rrij)
1486 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1487             call sc_angular
1488 C Calculate whole angle-dependent part of epsilon and contributions
1489 C to its derivatives
1490             fac=(rrij*sigsq)**expon2
1491             e1=fac*fac*aa(itypi,itypj)
1492             e2=fac*bb(itypi,itypj)
1493             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1494             eps2der=evdwij*eps3rt
1495             eps3der=evdwij*eps2rt
1496             evdwij=evdwij*eps2rt*eps3rt
1497 #ifdef TSCSC
1498             if (bb(itypi,itypj).gt.0) then
1499                evdw_p=evdw_p+evdwij
1500             else
1501                evdw_m=evdw_m+evdwij
1502             endif
1503 #else
1504             evdw=evdw+evdwij
1505 #endif
1506             if (lprn) then
1507             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1508             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1509 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1510 cd     &        restyp(itypi),i,restyp(itypj),j,
1511 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1512 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1513 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1514 cd     &        evdwij
1515             endif
1516 C Calculate gradient components.
1517             e1=e1*eps1*eps2rt**2*eps3rt**2
1518             fac=-expon*(e1+evdwij)
1519             sigder=fac/sigsq
1520             fac=rrij*fac
1521 C Calculate radial part of the gradient
1522             gg(1)=xj*fac
1523             gg(2)=yj*fac
1524             gg(3)=zj*fac
1525 C Calculate the angular part of the gradient and sum add the contributions
1526 C to the appropriate components of the Cartesian gradient.
1527 #ifdef TSCSC
1528             if (bb(itypi,itypj).gt.0) then
1529                call sc_grad
1530             else
1531                call sc_grad_T
1532             endif
1533 #else
1534             call sc_grad
1535 #endif
1536           enddo      ! j
1537         enddo        ! iint
1538       enddo          ! i
1539 c     stop
1540       return
1541       end
1542 C-----------------------------------------------------------------------------
1543       subroutine egb(evdw,evdw_p,evdw_m)
1544 C
1545 C This subroutine calculates the interaction energy of nonbonded side chains
1546 C assuming the Gay-Berne potential of interaction.
1547 C
1548       implicit real*8 (a-h,o-z)
1549       include 'DIMENSIONS'
1550       include 'COMMON.GEO'
1551       include 'COMMON.VAR'
1552       include 'COMMON.LOCAL'
1553       include 'COMMON.CHAIN'
1554       include 'COMMON.DERIV'
1555       include 'COMMON.NAMES'
1556       include 'COMMON.INTERACT'
1557       include 'COMMON.IOUNITS'
1558       include 'COMMON.CALC'
1559       include 'COMMON.CONTROL'
1560       include 'COMMON.SBRIDGE'
1561       logical lprn
1562       evdw=0.0D0
1563 ccccc      energy_dec=.false.
1564 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1565       evdw=0.0D0
1566       evdw_p=0.0D0
1567       evdw_m=0.0D0
1568       lprn=.false.
1569 c     if (icall.eq.0) lprn=.false.
1570       ind=0
1571       do i=iatsc_s,iatsc_e
1572         itypi=itype(i)
1573         itypi1=itype(i+1)
1574         xi=c(1,nres+i)
1575         yi=c(2,nres+i)
1576         zi=c(3,nres+i)
1577         dxi=dc_norm(1,nres+i)
1578         dyi=dc_norm(2,nres+i)
1579         dzi=dc_norm(3,nres+i)
1580 c        dsci_inv=dsc_inv(itypi)
1581         dsci_inv=vbld_inv(i+nres)
1582 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1583 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1584 C
1585 C Calculate SC interaction energy.
1586 C
1587         do iint=1,nint_gr(i)
1588           do j=istart(i,iint),iend(i,iint)
1589             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1590               call dyn_ssbond_ene(i,j,evdwij)
1591               evdw=evdw+evdwij
1592             ELSE
1593             ind=ind+1
1594             itypj=itype(j)
1595 c            dscj_inv=dsc_inv(itypj)
1596             dscj_inv=vbld_inv(j+nres)
1597 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1598 c     &       1.0d0/vbld(j+nres)
1599 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1600             sig0ij=sigma(itypi,itypj)
1601             chi1=chi(itypi,itypj)
1602             chi2=chi(itypj,itypi)
1603             chi12=chi1*chi2
1604             chip1=chip(itypi)
1605             chip2=chip(itypj)
1606             chip12=chip1*chip2
1607             alf1=alp(itypi)
1608             alf2=alp(itypj)
1609             alf12=0.5D0*(alf1+alf2)
1610 C For diagnostics only!!!
1611 c           chi1=0.0D0
1612 c           chi2=0.0D0
1613 c           chi12=0.0D0
1614 c           chip1=0.0D0
1615 c           chip2=0.0D0
1616 c           chip12=0.0D0
1617 c           alf1=0.0D0
1618 c           alf2=0.0D0
1619 c           alf12=0.0D0
1620             xj=c(1,nres+j)-xi
1621             yj=c(2,nres+j)-yi
1622             zj=c(3,nres+j)-zi
1623             dxj=dc_norm(1,nres+j)
1624             dyj=dc_norm(2,nres+j)
1625             dzj=dc_norm(3,nres+j)
1626 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1627 c            write (iout,*) "j",j," dc_norm",
1628 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1629             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1630             rij=dsqrt(rrij)
1631 C Calculate angle-dependent terms of energy and contributions to their
1632 C derivatives.
1633             call sc_angular
1634             sigsq=1.0D0/sigsq
1635             sig=sig0ij*dsqrt(sigsq)
1636             rij_shift=1.0D0/rij-sig+sig0ij
1637 c for diagnostics; uncomment
1638 c            rij_shift=1.2*sig0ij
1639 C I hate to put IF's in the loops, but here don't have another choice!!!!
1640             if (rij_shift.le.0.0D0) then
1641               evdw=1.0D20
1642 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1643 cd     &        restyp(itypi),i,restyp(itypj),j,
1644 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1645               return
1646             endif
1647             sigder=-sig*sigsq
1648 c---------------------------------------------------------------
1649             rij_shift=1.0D0/rij_shift
1650             fac=rij_shift**expon
1651             e1=fac*fac*aa(itypi,itypj)
1652             e2=fac*bb(itypi,itypj)
1653             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1654             eps2der=evdwij*eps3rt
1655             eps3der=evdwij*eps2rt
1656 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1657 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1658             evdwij=evdwij*eps2rt*eps3rt
1659 #ifdef TSCSC
1660             if (bb(itypi,itypj).gt.0) then
1661                evdw_p=evdw_p+evdwij
1662             else
1663                evdw_m=evdw_m+evdwij
1664             endif
1665 #else
1666             evdw=evdw+evdwij
1667 #endif
1668             if (lprn) then
1669             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1670             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1671             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1672      &        restyp(itypi),i,restyp(itypj),j,
1673      &        epsi,sigm,chi1,chi2,chip1,chip2,
1674      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1675      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1676      &        evdwij
1677             endif
1678
1679             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1680      &                        'evdw',i,j,evdwij
1681
1682 C Calculate gradient components.
1683             e1=e1*eps1*eps2rt**2*eps3rt**2
1684             fac=-expon*(e1+evdwij)*rij_shift
1685             sigder=fac*sigder
1686             fac=rij*fac
1687 c            fac=0.0d0
1688 C Calculate the radial part of the gradient
1689             gg(1)=xj*fac
1690             gg(2)=yj*fac
1691             gg(3)=zj*fac
1692 C Calculate angular part of the gradient.
1693 #ifdef TSCSC
1694             if (bb(itypi,itypj).gt.0) then
1695                call sc_grad
1696             else
1697                call sc_grad_T
1698             endif
1699 #else
1700             call sc_grad
1701 #endif
1702             ENDIF    ! dyn_ss
1703           enddo      ! j
1704         enddo        ! iint
1705       enddo          ! i
1706 c      write (iout,*) "Number of loop steps in EGB:",ind
1707 cccc      energy_dec=.false.
1708       return
1709       end
1710 C-----------------------------------------------------------------------------
1711       subroutine egbv(evdw,evdw_p,evdw_m)
1712 C
1713 C This subroutine calculates the interaction energy of nonbonded side chains
1714 C assuming the Gay-Berne-Vorobjev potential of interaction.
1715 C
1716       implicit real*8 (a-h,o-z)
1717       include 'DIMENSIONS'
1718       include 'COMMON.GEO'
1719       include 'COMMON.VAR'
1720       include 'COMMON.LOCAL'
1721       include 'COMMON.CHAIN'
1722       include 'COMMON.DERIV'
1723       include 'COMMON.NAMES'
1724       include 'COMMON.INTERACT'
1725       include 'COMMON.IOUNITS'
1726       include 'COMMON.CALC'
1727       common /srutu/ icall
1728       logical lprn
1729       evdw=0.0D0
1730 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1731       evdw=0.0D0
1732       lprn=.false.
1733 c     if (icall.eq.0) lprn=.true.
1734       ind=0
1735       do i=iatsc_s,iatsc_e
1736         itypi=itype(i)
1737         itypi1=itype(i+1)
1738         xi=c(1,nres+i)
1739         yi=c(2,nres+i)
1740         zi=c(3,nres+i)
1741         dxi=dc_norm(1,nres+i)
1742         dyi=dc_norm(2,nres+i)
1743         dzi=dc_norm(3,nres+i)
1744 c        dsci_inv=dsc_inv(itypi)
1745         dsci_inv=vbld_inv(i+nres)
1746 C
1747 C Calculate SC interaction energy.
1748 C
1749         do iint=1,nint_gr(i)
1750           do j=istart(i,iint),iend(i,iint)
1751             ind=ind+1
1752             itypj=itype(j)
1753 c            dscj_inv=dsc_inv(itypj)
1754             dscj_inv=vbld_inv(j+nres)
1755             sig0ij=sigma(itypi,itypj)
1756             r0ij=r0(itypi,itypj)
1757             chi1=chi(itypi,itypj)
1758             chi2=chi(itypj,itypi)
1759             chi12=chi1*chi2
1760             chip1=chip(itypi)
1761             chip2=chip(itypj)
1762             chip12=chip1*chip2
1763             alf1=alp(itypi)
1764             alf2=alp(itypj)
1765             alf12=0.5D0*(alf1+alf2)
1766 C For diagnostics only!!!
1767 c           chi1=0.0D0
1768 c           chi2=0.0D0
1769 c           chi12=0.0D0
1770 c           chip1=0.0D0
1771 c           chip2=0.0D0
1772 c           chip12=0.0D0
1773 c           alf1=0.0D0
1774 c           alf2=0.0D0
1775 c           alf12=0.0D0
1776             xj=c(1,nres+j)-xi
1777             yj=c(2,nres+j)-yi
1778             zj=c(3,nres+j)-zi
1779             dxj=dc_norm(1,nres+j)
1780             dyj=dc_norm(2,nres+j)
1781             dzj=dc_norm(3,nres+j)
1782             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1783             rij=dsqrt(rrij)
1784 C Calculate angle-dependent terms of energy and contributions to their
1785 C derivatives.
1786             call sc_angular
1787             sigsq=1.0D0/sigsq
1788             sig=sig0ij*dsqrt(sigsq)
1789             rij_shift=1.0D0/rij-sig+r0ij
1790 C I hate to put IF's in the loops, but here don't have another choice!!!!
1791             if (rij_shift.le.0.0D0) then
1792               evdw=1.0D20
1793               return
1794             endif
1795             sigder=-sig*sigsq
1796 c---------------------------------------------------------------
1797             rij_shift=1.0D0/rij_shift
1798             fac=rij_shift**expon
1799             e1=fac*fac*aa(itypi,itypj)
1800             e2=fac*bb(itypi,itypj)
1801             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1802             eps2der=evdwij*eps3rt
1803             eps3der=evdwij*eps2rt
1804             fac_augm=rrij**expon
1805             e_augm=augm(itypi,itypj)*fac_augm
1806             evdwij=evdwij*eps2rt*eps3rt
1807 #ifdef TSCSC
1808             if (bb(itypi,itypj).gt.0) then
1809                evdw_p=evdw_p+evdwij+e_augm
1810             else
1811                evdw_m=evdw_m+evdwij+e_augm
1812             endif
1813 #else
1814             evdw=evdw+evdwij+e_augm
1815 #endif
1816             if (lprn) then
1817             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1818             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1819             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1820      &        restyp(itypi),i,restyp(itypj),j,
1821      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1822      &        chi1,chi2,chip1,chip2,
1823      &        eps1,eps2rt**2,eps3rt**2,
1824      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1825      &        evdwij+e_augm
1826             endif
1827 C Calculate gradient components.
1828             e1=e1*eps1*eps2rt**2*eps3rt**2
1829             fac=-expon*(e1+evdwij)*rij_shift
1830             sigder=fac*sigder
1831             fac=rij*fac-2*expon*rrij*e_augm
1832 C Calculate the radial part of the gradient
1833             gg(1)=xj*fac
1834             gg(2)=yj*fac
1835             gg(3)=zj*fac
1836 C Calculate angular part of the gradient.
1837 #ifdef TSCSC
1838             if (bb(itypi,itypj).gt.0) then
1839                call sc_grad
1840             else
1841                call sc_grad_T
1842             endif
1843 #else
1844             call sc_grad
1845 #endif
1846           enddo      ! j
1847         enddo        ! iint
1848       enddo          ! i
1849       end
1850 C-----------------------------------------------------------------------------
1851       subroutine sc_angular
1852 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1853 C om12. Called by ebp, egb, and egbv.
1854       implicit none
1855       include 'COMMON.CALC'
1856       include 'COMMON.IOUNITS'
1857       erij(1)=xj*rij
1858       erij(2)=yj*rij
1859       erij(3)=zj*rij
1860       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1861       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1862       om12=dxi*dxj+dyi*dyj+dzi*dzj
1863       chiom12=chi12*om12
1864 C Calculate eps1(om12) and its derivative in om12
1865       faceps1=1.0D0-om12*chiom12
1866       faceps1_inv=1.0D0/faceps1
1867       eps1=dsqrt(faceps1_inv)
1868 C Following variable is eps1*deps1/dom12
1869       eps1_om12=faceps1_inv*chiom12
1870 c diagnostics only
1871 c      faceps1_inv=om12
1872 c      eps1=om12
1873 c      eps1_om12=1.0d0
1874 c      write (iout,*) "om12",om12," eps1",eps1
1875 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1876 C and om12.
1877       om1om2=om1*om2
1878       chiom1=chi1*om1
1879       chiom2=chi2*om2
1880       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1881       sigsq=1.0D0-facsig*faceps1_inv
1882       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1883       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1884       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1885 c diagnostics only
1886 c      sigsq=1.0d0
1887 c      sigsq_om1=0.0d0
1888 c      sigsq_om2=0.0d0
1889 c      sigsq_om12=0.0d0
1890 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1891 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1892 c     &    " eps1",eps1
1893 C Calculate eps2 and its derivatives in om1, om2, and om12.
1894       chipom1=chip1*om1
1895       chipom2=chip2*om2
1896       chipom12=chip12*om12
1897       facp=1.0D0-om12*chipom12
1898       facp_inv=1.0D0/facp
1899       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1900 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1901 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1902 C Following variable is the square root of eps2
1903       eps2rt=1.0D0-facp1*facp_inv
1904 C Following three variables are the derivatives of the square root of eps
1905 C in om1, om2, and om12.
1906       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1907       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1908       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1909 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1910       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1911 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1912 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1913 c     &  " eps2rt_om12",eps2rt_om12
1914 C Calculate whole angle-dependent part of epsilon and contributions
1915 C to its derivatives
1916       return
1917       end
1918
1919 C----------------------------------------------------------------------------
1920       subroutine sc_grad_T
1921       implicit real*8 (a-h,o-z)
1922       include 'DIMENSIONS'
1923       include 'COMMON.CHAIN'
1924       include 'COMMON.DERIV'
1925       include 'COMMON.CALC'
1926       include 'COMMON.IOUNITS'
1927       double precision dcosom1(3),dcosom2(3)
1928       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1929       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1930       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1931      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1932 c diagnostics only
1933 c      eom1=0.0d0
1934 c      eom2=0.0d0
1935 c      eom12=evdwij*eps1_om12
1936 c end diagnostics
1937 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1938 c     &  " sigder",sigder
1939 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1940 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1941       do k=1,3
1942         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1943         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1944       enddo
1945       do k=1,3
1946         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1947       enddo
1948 c      write (iout,*) "gg",(gg(k),k=1,3)
1949       do k=1,3
1950         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1951      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1952      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1953         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1954      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1955      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1956 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1957 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1958 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1959 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1960       enddo
1961 C
1962 C Calculate the components of the gradient in DC and X
1963 C
1964 cgrad      do k=i,j-1
1965 cgrad        do l=1,3
1966 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1967 cgrad        enddo
1968 cgrad      enddo
1969       do l=1,3
1970         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1971         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1972       enddo
1973       return
1974       end
1975
1976 C----------------------------------------------------------------------------
1977       subroutine sc_grad
1978       implicit real*8 (a-h,o-z)
1979       include 'DIMENSIONS'
1980       include 'COMMON.CHAIN'
1981       include 'COMMON.DERIV'
1982       include 'COMMON.CALC'
1983       include 'COMMON.IOUNITS'
1984       double precision dcosom1(3),dcosom2(3)
1985       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1986       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1987       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1988      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1989 c diagnostics only
1990 c      eom1=0.0d0
1991 c      eom2=0.0d0
1992 c      eom12=evdwij*eps1_om12
1993 c end diagnostics
1994 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1995 c     &  " sigder",sigder
1996 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1997 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1998       do k=1,3
1999         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2000         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2001       enddo
2002       do k=1,3
2003         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2004       enddo
2005 c      write (iout,*) "gg",(gg(k),k=1,3)
2006       do k=1,3
2007         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2008      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2009      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2010         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2011      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2012      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2013 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2014 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2015 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2016 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2017       enddo
2018 C
2019 C Calculate the components of the gradient in DC and X
2020 C
2021 cgrad      do k=i,j-1
2022 cgrad        do l=1,3
2023 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2024 cgrad        enddo
2025 cgrad      enddo
2026       do l=1,3
2027         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2028         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2029       enddo
2030       return
2031       end
2032 C-----------------------------------------------------------------------
2033       subroutine e_softsphere(evdw)
2034 C
2035 C This subroutine calculates the interaction energy of nonbonded side chains
2036 C assuming the LJ potential of interaction.
2037 C
2038       implicit real*8 (a-h,o-z)
2039       include 'DIMENSIONS'
2040       parameter (accur=1.0d-10)
2041       include 'COMMON.GEO'
2042       include 'COMMON.VAR'
2043       include 'COMMON.LOCAL'
2044       include 'COMMON.CHAIN'
2045       include 'COMMON.DERIV'
2046       include 'COMMON.INTERACT'
2047       include 'COMMON.TORSION'
2048       include 'COMMON.SBRIDGE'
2049       include 'COMMON.NAMES'
2050       include 'COMMON.IOUNITS'
2051       include 'COMMON.CONTACTS'
2052       dimension gg(3)
2053 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2054       evdw=0.0D0
2055       do i=iatsc_s,iatsc_e
2056         itypi=itype(i)
2057         itypi1=itype(i+1)
2058         xi=c(1,nres+i)
2059         yi=c(2,nres+i)
2060         zi=c(3,nres+i)
2061 C
2062 C Calculate SC interaction energy.
2063 C
2064         do iint=1,nint_gr(i)
2065 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2066 cd   &                  'iend=',iend(i,iint)
2067           do j=istart(i,iint),iend(i,iint)
2068             itypj=itype(j)
2069             xj=c(1,nres+j)-xi
2070             yj=c(2,nres+j)-yi
2071             zj=c(3,nres+j)-zi
2072             rij=xj*xj+yj*yj+zj*zj
2073 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2074             r0ij=r0(itypi,itypj)
2075             r0ijsq=r0ij*r0ij
2076 c            print *,i,j,r0ij,dsqrt(rij)
2077             if (rij.lt.r0ijsq) then
2078               evdwij=0.25d0*(rij-r0ijsq)**2
2079               fac=rij-r0ijsq
2080             else
2081               evdwij=0.0d0
2082               fac=0.0d0
2083             endif
2084             evdw=evdw+evdwij
2085 C
2086 C Calculate the components of the gradient in DC and X
2087 C
2088             gg(1)=xj*fac
2089             gg(2)=yj*fac
2090             gg(3)=zj*fac
2091             do k=1,3
2092               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2093               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2094               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2095               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2096             enddo
2097 cgrad            do k=i,j-1
2098 cgrad              do l=1,3
2099 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2100 cgrad              enddo
2101 cgrad            enddo
2102           enddo ! j
2103         enddo ! iint
2104       enddo ! i
2105       return
2106       end
2107 C--------------------------------------------------------------------------
2108       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2109      &              eello_turn4)
2110 C
2111 C Soft-sphere potential of p-p interaction
2112 C
2113       implicit real*8 (a-h,o-z)
2114       include 'DIMENSIONS'
2115       include 'COMMON.CONTROL'
2116       include 'COMMON.IOUNITS'
2117       include 'COMMON.GEO'
2118       include 'COMMON.VAR'
2119       include 'COMMON.LOCAL'
2120       include 'COMMON.CHAIN'
2121       include 'COMMON.DERIV'
2122       include 'COMMON.INTERACT'
2123       include 'COMMON.CONTACTS'
2124       include 'COMMON.TORSION'
2125       include 'COMMON.VECTORS'
2126       include 'COMMON.FFIELD'
2127       dimension ggg(3)
2128 cd      write(iout,*) 'In EELEC_soft_sphere'
2129       ees=0.0D0
2130       evdw1=0.0D0
2131       eel_loc=0.0d0
2132       eello_turn3=0.0d0
2133       eello_turn4=0.0d0
2134       ind=0
2135       do i=iatel_s,iatel_e
2136         dxi=dc(1,i)
2137         dyi=dc(2,i)
2138         dzi=dc(3,i)
2139         xmedi=c(1,i)+0.5d0*dxi
2140         ymedi=c(2,i)+0.5d0*dyi
2141         zmedi=c(3,i)+0.5d0*dzi
2142         num_conti=0
2143 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2144         do j=ielstart(i),ielend(i)
2145           ind=ind+1
2146           iteli=itel(i)
2147           itelj=itel(j)
2148           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2149           r0ij=rpp(iteli,itelj)
2150           r0ijsq=r0ij*r0ij
2151           dxj=dc(1,j)
2152           dyj=dc(2,j)
2153           dzj=dc(3,j)
2154           xj=c(1,j)+0.5D0*dxj-xmedi
2155           yj=c(2,j)+0.5D0*dyj-ymedi
2156           zj=c(3,j)+0.5D0*dzj-zmedi
2157           rij=xj*xj+yj*yj+zj*zj
2158           if (rij.lt.r0ijsq) then
2159             evdw1ij=0.25d0*(rij-r0ijsq)**2
2160             fac=rij-r0ijsq
2161           else
2162             evdw1ij=0.0d0
2163             fac=0.0d0
2164           endif
2165           evdw1=evdw1+evdw1ij
2166 C
2167 C Calculate contributions to the Cartesian gradient.
2168 C
2169           ggg(1)=fac*xj
2170           ggg(2)=fac*yj
2171           ggg(3)=fac*zj
2172           do k=1,3
2173             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2174             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2175           enddo
2176 *
2177 * Loop over residues i+1 thru j-1.
2178 *
2179 cgrad          do k=i+1,j-1
2180 cgrad            do l=1,3
2181 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2182 cgrad            enddo
2183 cgrad          enddo
2184         enddo ! j
2185       enddo   ! i
2186 cgrad      do i=nnt,nct-1
2187 cgrad        do k=1,3
2188 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2189 cgrad        enddo
2190 cgrad        do j=i+1,nct-1
2191 cgrad          do k=1,3
2192 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2193 cgrad          enddo
2194 cgrad        enddo
2195 cgrad      enddo
2196       return
2197       end
2198 c------------------------------------------------------------------------------
2199       subroutine vec_and_deriv
2200       implicit real*8 (a-h,o-z)
2201       include 'DIMENSIONS'
2202 #ifdef MPI
2203       include 'mpif.h'
2204 #endif
2205       include 'COMMON.IOUNITS'
2206       include 'COMMON.GEO'
2207       include 'COMMON.VAR'
2208       include 'COMMON.LOCAL'
2209       include 'COMMON.CHAIN'
2210       include 'COMMON.VECTORS'
2211       include 'COMMON.SETUP'
2212       include 'COMMON.TIME1'
2213       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2214 C Compute the local reference systems. For reference system (i), the
2215 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2216 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2217 #ifdef PARVEC
2218       do i=ivec_start,ivec_end
2219 #else
2220       do i=1,nres-1
2221 #endif
2222           if (i.eq.nres-1) then
2223 C Case of the last full residue
2224 C Compute the Z-axis
2225             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2226             costh=dcos(pi-theta(nres))
2227             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2228             do k=1,3
2229               uz(k,i)=fac*uz(k,i)
2230             enddo
2231 C Compute the derivatives of uz
2232             uzder(1,1,1)= 0.0d0
2233             uzder(2,1,1)=-dc_norm(3,i-1)
2234             uzder(3,1,1)= dc_norm(2,i-1)
2235             uzder(1,2,1)= dc_norm(3,i-1)
2236             uzder(2,2,1)= 0.0d0
2237             uzder(3,2,1)=-dc_norm(1,i-1)
2238             uzder(1,3,1)=-dc_norm(2,i-1)
2239             uzder(2,3,1)= dc_norm(1,i-1)
2240             uzder(3,3,1)= 0.0d0
2241             uzder(1,1,2)= 0.0d0
2242             uzder(2,1,2)= dc_norm(3,i)
2243             uzder(3,1,2)=-dc_norm(2,i)
2244             uzder(1,2,2)=-dc_norm(3,i)
2245             uzder(2,2,2)= 0.0d0
2246             uzder(3,2,2)= dc_norm(1,i)
2247             uzder(1,3,2)= dc_norm(2,i)
2248             uzder(2,3,2)=-dc_norm(1,i)
2249             uzder(3,3,2)= 0.0d0
2250 C Compute the Y-axis
2251             facy=fac
2252             do k=1,3
2253               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2254             enddo
2255 C Compute the derivatives of uy
2256             do j=1,3
2257               do k=1,3
2258                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2259      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2260                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2261               enddo
2262               uyder(j,j,1)=uyder(j,j,1)-costh
2263               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2264             enddo
2265             do j=1,2
2266               do k=1,3
2267                 do l=1,3
2268                   uygrad(l,k,j,i)=uyder(l,k,j)
2269                   uzgrad(l,k,j,i)=uzder(l,k,j)
2270                 enddo
2271               enddo
2272             enddo
2273             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2274             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2275             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2276             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2277           else
2278 C Other residues
2279 C Compute the Z-axis
2280             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2281             costh=dcos(pi-theta(i+2))
2282             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2283             do k=1,3
2284               uz(k,i)=fac*uz(k,i)
2285             enddo
2286 C Compute the derivatives of uz
2287             uzder(1,1,1)= 0.0d0
2288             uzder(2,1,1)=-dc_norm(3,i+1)
2289             uzder(3,1,1)= dc_norm(2,i+1)
2290             uzder(1,2,1)= dc_norm(3,i+1)
2291             uzder(2,2,1)= 0.0d0
2292             uzder(3,2,1)=-dc_norm(1,i+1)
2293             uzder(1,3,1)=-dc_norm(2,i+1)
2294             uzder(2,3,1)= dc_norm(1,i+1)
2295             uzder(3,3,1)= 0.0d0
2296             uzder(1,1,2)= 0.0d0
2297             uzder(2,1,2)= dc_norm(3,i)
2298             uzder(3,1,2)=-dc_norm(2,i)
2299             uzder(1,2,2)=-dc_norm(3,i)
2300             uzder(2,2,2)= 0.0d0
2301             uzder(3,2,2)= dc_norm(1,i)
2302             uzder(1,3,2)= dc_norm(2,i)
2303             uzder(2,3,2)=-dc_norm(1,i)
2304             uzder(3,3,2)= 0.0d0
2305 C Compute the Y-axis
2306             facy=fac
2307             do k=1,3
2308               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2309             enddo
2310 C Compute the derivatives of uy
2311             do j=1,3
2312               do k=1,3
2313                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2314      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2315                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2316               enddo
2317               uyder(j,j,1)=uyder(j,j,1)-costh
2318               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2319             enddo
2320             do j=1,2
2321               do k=1,3
2322                 do l=1,3
2323                   uygrad(l,k,j,i)=uyder(l,k,j)
2324                   uzgrad(l,k,j,i)=uzder(l,k,j)
2325                 enddo
2326               enddo
2327             enddo
2328             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2329             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2330             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2331             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2332           endif
2333       enddo
2334       do i=1,nres-1
2335         vbld_inv_temp(1)=vbld_inv(i+1)
2336         if (i.lt.nres-1) then
2337           vbld_inv_temp(2)=vbld_inv(i+2)
2338           else
2339           vbld_inv_temp(2)=vbld_inv(i)
2340           endif
2341         do j=1,2
2342           do k=1,3
2343             do l=1,3
2344               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2345               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2346             enddo
2347           enddo
2348         enddo
2349       enddo
2350 #if defined(PARVEC) && defined(MPI)
2351       if (nfgtasks1.gt.1) then
2352         time00=MPI_Wtime()
2353 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2354 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2355 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2356         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2357      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2358      &   FG_COMM1,IERR)
2359         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2360      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2361      &   FG_COMM1,IERR)
2362         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2363      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2364      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2365         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2366      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2367      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2368         time_gather=time_gather+MPI_Wtime()-time00
2369       endif
2370 c      if (fg_rank.eq.0) then
2371 c        write (iout,*) "Arrays UY and UZ"
2372 c        do i=1,nres-1
2373 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2374 c     &     (uz(k,i),k=1,3)
2375 c        enddo
2376 c      endif
2377 #endif
2378       return
2379       end
2380 C-----------------------------------------------------------------------------
2381       subroutine check_vecgrad
2382       implicit real*8 (a-h,o-z)
2383       include 'DIMENSIONS'
2384       include 'COMMON.IOUNITS'
2385       include 'COMMON.GEO'
2386       include 'COMMON.VAR'
2387       include 'COMMON.LOCAL'
2388       include 'COMMON.CHAIN'
2389       include 'COMMON.VECTORS'
2390       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2391       dimension uyt(3,maxres),uzt(3,maxres)
2392       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2393       double precision delta /1.0d-7/
2394       call vec_and_deriv
2395 cd      do i=1,nres
2396 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2397 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2398 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2399 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2400 cd     &     (dc_norm(if90,i),if90=1,3)
2401 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2402 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2403 cd          write(iout,'(a)')
2404 cd      enddo
2405       do i=1,nres
2406         do j=1,2
2407           do k=1,3
2408             do l=1,3
2409               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2410               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2411             enddo
2412           enddo
2413         enddo
2414       enddo
2415       call vec_and_deriv
2416       do i=1,nres
2417         do j=1,3
2418           uyt(j,i)=uy(j,i)
2419           uzt(j,i)=uz(j,i)
2420         enddo
2421       enddo
2422       do i=1,nres
2423 cd        write (iout,*) 'i=',i
2424         do k=1,3
2425           erij(k)=dc_norm(k,i)
2426         enddo
2427         do j=1,3
2428           do k=1,3
2429             dc_norm(k,i)=erij(k)
2430           enddo
2431           dc_norm(j,i)=dc_norm(j,i)+delta
2432 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2433 c          do k=1,3
2434 c            dc_norm(k,i)=dc_norm(k,i)/fac
2435 c          enddo
2436 c          write (iout,*) (dc_norm(k,i),k=1,3)
2437 c          write (iout,*) (erij(k),k=1,3)
2438           call vec_and_deriv
2439           do k=1,3
2440             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2441             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2442             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2443             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2444           enddo
2445 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2446 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2447 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2448         enddo
2449         do k=1,3
2450           dc_norm(k,i)=erij(k)
2451         enddo
2452 cd        do k=1,3
2453 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2454 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2455 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2456 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2457 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2458 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2459 cd          write (iout,'(a)')
2460 cd        enddo
2461       enddo
2462       return
2463       end
2464 C--------------------------------------------------------------------------
2465       subroutine set_matrices
2466       implicit real*8 (a-h,o-z)
2467       include 'DIMENSIONS'
2468 #ifdef MPI
2469       include "mpif.h"
2470       include "COMMON.SETUP"
2471       integer IERR
2472       integer status(MPI_STATUS_SIZE)
2473 #endif
2474       include 'COMMON.IOUNITS'
2475       include 'COMMON.GEO'
2476       include 'COMMON.VAR'
2477       include 'COMMON.LOCAL'
2478       include 'COMMON.CHAIN'
2479       include 'COMMON.DERIV'
2480       include 'COMMON.INTERACT'
2481       include 'COMMON.CONTACTS'
2482       include 'COMMON.TORSION'
2483       include 'COMMON.VECTORS'
2484       include 'COMMON.FFIELD'
2485       double precision auxvec(2),auxmat(2,2)
2486 C
2487 C Compute the virtual-bond-torsional-angle dependent quantities needed
2488 C to calculate the el-loc multibody terms of various order.
2489 C
2490 #ifdef PARMAT
2491       do i=ivec_start+2,ivec_end+2
2492 #else
2493       do i=3,nres+1
2494 #endif
2495         if (i .lt. nres+1) then
2496           sin1=dsin(phi(i))
2497           cos1=dcos(phi(i))
2498           sintab(i-2)=sin1
2499           costab(i-2)=cos1
2500           obrot(1,i-2)=cos1
2501           obrot(2,i-2)=sin1
2502           sin2=dsin(2*phi(i))
2503           cos2=dcos(2*phi(i))
2504           sintab2(i-2)=sin2
2505           costab2(i-2)=cos2
2506           obrot2(1,i-2)=cos2
2507           obrot2(2,i-2)=sin2
2508           Ug(1,1,i-2)=-cos1
2509           Ug(1,2,i-2)=-sin1
2510           Ug(2,1,i-2)=-sin1
2511           Ug(2,2,i-2)= cos1
2512           Ug2(1,1,i-2)=-cos2
2513           Ug2(1,2,i-2)=-sin2
2514           Ug2(2,1,i-2)=-sin2
2515           Ug2(2,2,i-2)= cos2
2516         else
2517           costab(i-2)=1.0d0
2518           sintab(i-2)=0.0d0
2519           obrot(1,i-2)=1.0d0
2520           obrot(2,i-2)=0.0d0
2521           obrot2(1,i-2)=0.0d0
2522           obrot2(2,i-2)=0.0d0
2523           Ug(1,1,i-2)=1.0d0
2524           Ug(1,2,i-2)=0.0d0
2525           Ug(2,1,i-2)=0.0d0
2526           Ug(2,2,i-2)=1.0d0
2527           Ug2(1,1,i-2)=0.0d0
2528           Ug2(1,2,i-2)=0.0d0
2529           Ug2(2,1,i-2)=0.0d0
2530           Ug2(2,2,i-2)=0.0d0
2531         endif
2532         if (i .gt. 3 .and. i .lt. nres+1) then
2533           obrot_der(1,i-2)=-sin1
2534           obrot_der(2,i-2)= cos1
2535           Ugder(1,1,i-2)= sin1
2536           Ugder(1,2,i-2)=-cos1
2537           Ugder(2,1,i-2)=-cos1
2538           Ugder(2,2,i-2)=-sin1
2539           dwacos2=cos2+cos2
2540           dwasin2=sin2+sin2
2541           obrot2_der(1,i-2)=-dwasin2
2542           obrot2_der(2,i-2)= dwacos2
2543           Ug2der(1,1,i-2)= dwasin2
2544           Ug2der(1,2,i-2)=-dwacos2
2545           Ug2der(2,1,i-2)=-dwacos2
2546           Ug2der(2,2,i-2)=-dwasin2
2547         else
2548           obrot_der(1,i-2)=0.0d0
2549           obrot_der(2,i-2)=0.0d0
2550           Ugder(1,1,i-2)=0.0d0
2551           Ugder(1,2,i-2)=0.0d0
2552           Ugder(2,1,i-2)=0.0d0
2553           Ugder(2,2,i-2)=0.0d0
2554           obrot2_der(1,i-2)=0.0d0
2555           obrot2_der(2,i-2)=0.0d0
2556           Ug2der(1,1,i-2)=0.0d0
2557           Ug2der(1,2,i-2)=0.0d0
2558           Ug2der(2,1,i-2)=0.0d0
2559           Ug2der(2,2,i-2)=0.0d0
2560         endif
2561 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2562         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2563           iti = itortyp(itype(i-2))
2564         else
2565           iti=ntortyp+1
2566         endif
2567 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2568         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2569           iti1 = itortyp(itype(i-1))
2570         else
2571           iti1=ntortyp+1
2572         endif
2573 cd        write (iout,*) '*******i',i,' iti1',iti
2574 cd        write (iout,*) 'b1',b1(:,iti)
2575 cd        write (iout,*) 'b2',b2(:,iti)
2576 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2577 c        if (i .gt. iatel_s+2) then
2578         if (i .gt. nnt+2) then
2579           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2580           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2581           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2582      &    then
2583           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2584           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2585           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2586           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2587           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2588           endif
2589         else
2590           do k=1,2
2591             Ub2(k,i-2)=0.0d0
2592             Ctobr(k,i-2)=0.0d0
2593             Dtobr2(k,i-2)=0.0d0
2594             do l=1,2
2595               EUg(l,k,i-2)=0.0d0
2596               CUg(l,k,i-2)=0.0d0
2597               DUg(l,k,i-2)=0.0d0
2598               DtUg2(l,k,i-2)=0.0d0
2599             enddo
2600           enddo
2601         endif
2602         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2603         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2604         do k=1,2
2605           muder(k,i-2)=Ub2der(k,i-2)
2606         enddo
2607 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2608         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2609           iti1 = itortyp(itype(i-1))
2610         else
2611           iti1=ntortyp+1
2612         endif
2613         do k=1,2
2614           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2615         enddo
2616 cd        write (iout,*) 'mu ',mu(:,i-2)
2617 cd        write (iout,*) 'mu1',mu1(:,i-2)
2618 cd        write (iout,*) 'mu2',mu2(:,i-2)
2619         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2620      &  then
2621         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2622         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2623         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2624         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2625         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2626 C Vectors and matrices dependent on a single virtual-bond dihedral.
2627         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2628         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2629         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2630         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2631         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2632         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2633         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2634         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2635         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2636         endif
2637       enddo
2638 C Matrices dependent on two consecutive virtual-bond dihedrals.
2639 C The order of matrices is from left to right.
2640       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2641      &then
2642 c      do i=max0(ivec_start,2),ivec_end
2643       do i=2,nres-1
2644         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2645         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2646         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2647         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2648         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2649         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2650         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2651         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2652       enddo
2653       endif
2654 #if defined(MPI) && defined(PARMAT)
2655 #ifdef DEBUG
2656 c      if (fg_rank.eq.0) then
2657         write (iout,*) "Arrays UG and UGDER before GATHER"
2658         do i=1,nres-1
2659           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2660      &     ((ug(l,k,i),l=1,2),k=1,2),
2661      &     ((ugder(l,k,i),l=1,2),k=1,2)
2662         enddo
2663         write (iout,*) "Arrays UG2 and UG2DER"
2664         do i=1,nres-1
2665           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2666      &     ((ug2(l,k,i),l=1,2),k=1,2),
2667      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2668         enddo
2669         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2670         do i=1,nres-1
2671           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2672      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2673      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2674         enddo
2675         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2676         do i=1,nres-1
2677           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2678      &     costab(i),sintab(i),costab2(i),sintab2(i)
2679         enddo
2680         write (iout,*) "Array MUDER"
2681         do i=1,nres-1
2682           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2683         enddo
2684 c      endif
2685 #endif
2686       if (nfgtasks.gt.1) then
2687         time00=MPI_Wtime()
2688 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2689 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2690 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2691 #ifdef MATGATHER
2692         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2693      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2694      &   FG_COMM1,IERR)
2695         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2696      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2697      &   FG_COMM1,IERR)
2698         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2699      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2700      &   FG_COMM1,IERR)
2701         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2702      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2703      &   FG_COMM1,IERR)
2704         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2705      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2706      &   FG_COMM1,IERR)
2707         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2708      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2709      &   FG_COMM1,IERR)
2710         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2711      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2712      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2713         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2714      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2715      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2716         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2717      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2718      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2719         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2720      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2721      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2722         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2723      &  then
2724         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2725      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2726      &   FG_COMM1,IERR)
2727         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2728      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2729      &   FG_COMM1,IERR)
2730         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2731      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2732      &   FG_COMM1,IERR)
2733        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2734      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2735      &   FG_COMM1,IERR)
2736         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2737      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2738      &   FG_COMM1,IERR)
2739         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2740      &   ivec_count(fg_rank1),
2741      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2742      &   FG_COMM1,IERR)
2743         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2744      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2745      &   FG_COMM1,IERR)
2746         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2747      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2748      &   FG_COMM1,IERR)
2749         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2750      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2751      &   FG_COMM1,IERR)
2752         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2753      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2754      &   FG_COMM1,IERR)
2755         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2756      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2757      &   FG_COMM1,IERR)
2758         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2759      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2760      &   FG_COMM1,IERR)
2761         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2762      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2763      &   FG_COMM1,IERR)
2764         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2765      &   ivec_count(fg_rank1),
2766      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2767      &   FG_COMM1,IERR)
2768         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2769      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2770      &   FG_COMM1,IERR)
2771        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2772      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2773      &   FG_COMM1,IERR)
2774         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2775      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2776      &   FG_COMM1,IERR)
2777        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2778      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2779      &   FG_COMM1,IERR)
2780         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2781      &   ivec_count(fg_rank1),
2782      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2783      &   FG_COMM1,IERR)
2784         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2785      &   ivec_count(fg_rank1),
2786      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2787      &   FG_COMM1,IERR)
2788         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2789      &   ivec_count(fg_rank1),
2790      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2791      &   MPI_MAT2,FG_COMM1,IERR)
2792         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2793      &   ivec_count(fg_rank1),
2794      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2795      &   MPI_MAT2,FG_COMM1,IERR)
2796         endif
2797 #else
2798 c Passes matrix info through the ring
2799       isend=fg_rank1
2800       irecv=fg_rank1-1
2801       if (irecv.lt.0) irecv=nfgtasks1-1
2802       iprev=irecv
2803       inext=fg_rank1+1
2804       if (inext.ge.nfgtasks1) inext=0
2805       do i=1,nfgtasks1-1
2806 c        write (iout,*) "isend",isend," irecv",irecv
2807 c        call flush(iout)
2808         lensend=lentyp(isend)
2809         lenrecv=lentyp(irecv)
2810 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2811 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2812 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2813 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2814 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2815 c        write (iout,*) "Gather ROTAT1"
2816 c        call flush(iout)
2817 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2818 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2819 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2820 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2821 c        write (iout,*) "Gather ROTAT2"
2822 c        call flush(iout)
2823         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2824      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2825      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2826      &   iprev,4400+irecv,FG_COMM,status,IERR)
2827 c        write (iout,*) "Gather ROTAT_OLD"
2828 c        call flush(iout)
2829         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2830      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2831      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2832      &   iprev,5500+irecv,FG_COMM,status,IERR)
2833 c        write (iout,*) "Gather PRECOMP11"
2834 c        call flush(iout)
2835         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2836      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2837      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2838      &   iprev,6600+irecv,FG_COMM,status,IERR)
2839 c        write (iout,*) "Gather PRECOMP12"
2840 c        call flush(iout)
2841         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2842      &  then
2843         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2844      &   MPI_ROTAT2(lensend),inext,7700+isend,
2845      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2846      &   iprev,7700+irecv,FG_COMM,status,IERR)
2847 c        write (iout,*) "Gather PRECOMP21"
2848 c        call flush(iout)
2849         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2850      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2851      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2852      &   iprev,8800+irecv,FG_COMM,status,IERR)
2853 c        write (iout,*) "Gather PRECOMP22"
2854 c        call flush(iout)
2855         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2856      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2857      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2858      &   MPI_PRECOMP23(lenrecv),
2859      &   iprev,9900+irecv,FG_COMM,status,IERR)
2860 c        write (iout,*) "Gather PRECOMP23"
2861 c        call flush(iout)
2862         endif
2863         isend=irecv
2864         irecv=irecv-1
2865         if (irecv.lt.0) irecv=nfgtasks1-1
2866       enddo
2867 #endif
2868         time_gather=time_gather+MPI_Wtime()-time00
2869       endif
2870 #ifdef DEBUG
2871 c      if (fg_rank.eq.0) then
2872         write (iout,*) "Arrays UG and UGDER"
2873         do i=1,nres-1
2874           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2875      &     ((ug(l,k,i),l=1,2),k=1,2),
2876      &     ((ugder(l,k,i),l=1,2),k=1,2)
2877         enddo
2878         write (iout,*) "Arrays UG2 and UG2DER"
2879         do i=1,nres-1
2880           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2881      &     ((ug2(l,k,i),l=1,2),k=1,2),
2882      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2883         enddo
2884         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2885         do i=1,nres-1
2886           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2887      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2888      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2889         enddo
2890         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2891         do i=1,nres-1
2892           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2893      &     costab(i),sintab(i),costab2(i),sintab2(i)
2894         enddo
2895         write (iout,*) "Array MUDER"
2896         do i=1,nres-1
2897           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2898         enddo
2899 c      endif
2900 #endif
2901 #endif
2902 cd      do i=1,nres
2903 cd        iti = itortyp(itype(i))
2904 cd        write (iout,*) i
2905 cd        do j=1,2
2906 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2907 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2908 cd        enddo
2909 cd      enddo
2910       return
2911       end
2912 C--------------------------------------------------------------------------
2913       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2914 C
2915 C This subroutine calculates the average interaction energy and its gradient
2916 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2917 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2918 C The potential depends both on the distance of peptide-group centers and on
2919 C the orientation of the CA-CA virtual bonds.
2920 C
2921       implicit real*8 (a-h,o-z)
2922 #ifdef MPI
2923       include 'mpif.h'
2924 #endif
2925       include 'DIMENSIONS'
2926       include 'COMMON.CONTROL'
2927       include 'COMMON.SETUP'
2928       include 'COMMON.IOUNITS'
2929       include 'COMMON.GEO'
2930       include 'COMMON.VAR'
2931       include 'COMMON.LOCAL'
2932       include 'COMMON.CHAIN'
2933       include 'COMMON.DERIV'
2934       include 'COMMON.INTERACT'
2935       include 'COMMON.CONTACTS'
2936       include 'COMMON.TORSION'
2937       include 'COMMON.VECTORS'
2938       include 'COMMON.FFIELD'
2939       include 'COMMON.TIME1'
2940       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2941      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2942       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2943      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2944       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2945      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2946      &    num_conti,j1,j2
2947 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2948 #ifdef MOMENT
2949       double precision scal_el /1.0d0/
2950 #else
2951       double precision scal_el /0.5d0/
2952 #endif
2953 C 12/13/98
2954 C 13-go grudnia roku pamietnego...
2955       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2956      &                   0.0d0,1.0d0,0.0d0,
2957      &                   0.0d0,0.0d0,1.0d0/
2958 cd      write(iout,*) 'In EELEC'
2959 cd      do i=1,nloctyp
2960 cd        write(iout,*) 'Type',i
2961 cd        write(iout,*) 'B1',B1(:,i)
2962 cd        write(iout,*) 'B2',B2(:,i)
2963 cd        write(iout,*) 'CC',CC(:,:,i)
2964 cd        write(iout,*) 'DD',DD(:,:,i)
2965 cd        write(iout,*) 'EE',EE(:,:,i)
2966 cd      enddo
2967 cd      call check_vecgrad
2968 cd      stop
2969       if (icheckgrad.eq.1) then
2970         do i=1,nres-1
2971           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2972           do k=1,3
2973             dc_norm(k,i)=dc(k,i)*fac
2974           enddo
2975 c          write (iout,*) 'i',i,' fac',fac
2976         enddo
2977       endif
2978       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2979      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2980      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2981 c        call vec_and_deriv
2982 #ifdef TIMING
2983         time01=MPI_Wtime()
2984 #endif
2985         call set_matrices
2986 #ifdef TIMING
2987         time_mat=time_mat+MPI_Wtime()-time01
2988 #endif
2989       endif
2990 cd      do i=1,nres-1
2991 cd        write (iout,*) 'i=',i
2992 cd        do k=1,3
2993 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2994 cd        enddo
2995 cd        do k=1,3
2996 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2997 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2998 cd        enddo
2999 cd      enddo
3000       t_eelecij=0.0d0
3001       ees=0.0D0
3002       evdw1=0.0D0
3003       eel_loc=0.0d0
3004       eello_turn3=0.0d0
3005       eello_turn4=0.0d0
3006       ind=0
3007       do i=1,nres
3008         num_cont_hb(i)=0
3009       enddo
3010 cd      print '(a)','Enter EELEC'
3011 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3012       do i=1,nres
3013         gel_loc_loc(i)=0.0d0
3014         gcorr_loc(i)=0.0d0
3015       enddo
3016 c
3017 c
3018 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3019 C
3020 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3021 C
3022       do i=iturn3_start,iturn3_end
3023         dxi=dc(1,i)
3024         dyi=dc(2,i)
3025         dzi=dc(3,i)
3026         dx_normi=dc_norm(1,i)
3027         dy_normi=dc_norm(2,i)
3028         dz_normi=dc_norm(3,i)
3029         xmedi=c(1,i)+0.5d0*dxi
3030         ymedi=c(2,i)+0.5d0*dyi
3031         zmedi=c(3,i)+0.5d0*dzi
3032         num_conti=0
3033         call eelecij(i,i+2,ees,evdw1,eel_loc)
3034         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3035         num_cont_hb(i)=num_conti
3036       enddo
3037       do i=iturn4_start,iturn4_end
3038         dxi=dc(1,i)
3039         dyi=dc(2,i)
3040         dzi=dc(3,i)
3041         dx_normi=dc_norm(1,i)
3042         dy_normi=dc_norm(2,i)
3043         dz_normi=dc_norm(3,i)
3044         xmedi=c(1,i)+0.5d0*dxi
3045         ymedi=c(2,i)+0.5d0*dyi
3046         zmedi=c(3,i)+0.5d0*dzi
3047         num_conti=num_cont_hb(i)
3048         call eelecij(i,i+3,ees,evdw1,eel_loc)
3049         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3050         num_cont_hb(i)=num_conti
3051       enddo   ! i
3052 c
3053 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3054 c
3055       do i=iatel_s,iatel_e
3056         dxi=dc(1,i)
3057         dyi=dc(2,i)
3058         dzi=dc(3,i)
3059         dx_normi=dc_norm(1,i)
3060         dy_normi=dc_norm(2,i)
3061         dz_normi=dc_norm(3,i)
3062         xmedi=c(1,i)+0.5d0*dxi
3063         ymedi=c(2,i)+0.5d0*dyi
3064         zmedi=c(3,i)+0.5d0*dzi
3065 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3066         num_conti=num_cont_hb(i)
3067         do j=ielstart(i),ielend(i)
3068           call eelecij(i,j,ees,evdw1,eel_loc)
3069         enddo ! j
3070         num_cont_hb(i)=num_conti
3071       enddo   ! i
3072 c      write (iout,*) "Number of loop steps in EELEC:",ind
3073 cd      do i=1,nres
3074 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3075 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3076 cd      enddo
3077 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3078 ccc      eel_loc=eel_loc+eello_turn3
3079 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3080       return
3081       end
3082 C-------------------------------------------------------------------------------
3083       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3084       implicit real*8 (a-h,o-z)
3085       include 'DIMENSIONS'
3086 #ifdef MPI
3087       include "mpif.h"
3088 #endif
3089       include 'COMMON.CONTROL'
3090       include 'COMMON.IOUNITS'
3091       include 'COMMON.GEO'
3092       include 'COMMON.VAR'
3093       include 'COMMON.LOCAL'
3094       include 'COMMON.CHAIN'
3095       include 'COMMON.DERIV'
3096       include 'COMMON.INTERACT'
3097       include 'COMMON.CONTACTS'
3098       include 'COMMON.TORSION'
3099       include 'COMMON.VECTORS'
3100       include 'COMMON.FFIELD'
3101       include 'COMMON.TIME1'
3102       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3103      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3104       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3105      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3106       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3107      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3108      &    num_conti,j1,j2
3109 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3110 #ifdef MOMENT
3111       double precision scal_el /1.0d0/
3112 #else
3113       double precision scal_el /0.5d0/
3114 #endif
3115 C 12/13/98
3116 C 13-go grudnia roku pamietnego...
3117       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3118      &                   0.0d0,1.0d0,0.0d0,
3119      &                   0.0d0,0.0d0,1.0d0/
3120 c          time00=MPI_Wtime()
3121 cd      write (iout,*) "eelecij",i,j
3122 c          ind=ind+1
3123           iteli=itel(i)
3124           itelj=itel(j)
3125           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3126           aaa=app(iteli,itelj)
3127           bbb=bpp(iteli,itelj)
3128           ael6i=ael6(iteli,itelj)
3129           ael3i=ael3(iteli,itelj)
3130           dxj=dc(1,j)
3131           dyj=dc(2,j)
3132           dzj=dc(3,j)
3133           dx_normj=dc_norm(1,j)
3134           dy_normj=dc_norm(2,j)
3135           dz_normj=dc_norm(3,j)
3136           xj=c(1,j)+0.5D0*dxj-xmedi
3137           yj=c(2,j)+0.5D0*dyj-ymedi
3138           zj=c(3,j)+0.5D0*dzj-zmedi
3139           rij=xj*xj+yj*yj+zj*zj
3140           rrmij=1.0D0/rij
3141           rij=dsqrt(rij)
3142           rmij=1.0D0/rij
3143           r3ij=rrmij*rmij
3144           r6ij=r3ij*r3ij
3145           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3146           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3147           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3148           fac=cosa-3.0D0*cosb*cosg
3149           ev1=aaa*r6ij*r6ij
3150 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3151           if (j.eq.i+2) ev1=scal_el*ev1
3152           ev2=bbb*r6ij
3153           fac3=ael6i*r6ij
3154           fac4=ael3i*r3ij
3155           evdwij=ev1+ev2
3156           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3157           el2=fac4*fac
3158           eesij=el1+el2
3159 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3160           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3161           ees=ees+eesij
3162           evdw1=evdw1+evdwij
3163 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3164 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3165 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3166 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3167
3168           if (energy_dec) then
3169               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3170               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3171           endif
3172
3173 C
3174 C Calculate contributions to the Cartesian gradient.
3175 C
3176 #ifdef SPLITELE
3177           facvdw=-6*rrmij*(ev1+evdwij)
3178           facel=-3*rrmij*(el1+eesij)
3179           fac1=fac
3180           erij(1)=xj*rmij
3181           erij(2)=yj*rmij
3182           erij(3)=zj*rmij
3183 *
3184 * Radial derivatives. First process both termini of the fragment (i,j)
3185 *
3186           ggg(1)=facel*xj
3187           ggg(2)=facel*yj
3188           ggg(3)=facel*zj
3189 c          do k=1,3
3190 c            ghalf=0.5D0*ggg(k)
3191 c            gelc(k,i)=gelc(k,i)+ghalf
3192 c            gelc(k,j)=gelc(k,j)+ghalf
3193 c          enddo
3194 c 9/28/08 AL Gradient compotents will be summed only at the end
3195           do k=1,3
3196             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3197             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3198           enddo
3199 *
3200 * Loop over residues i+1 thru j-1.
3201 *
3202 cgrad          do k=i+1,j-1
3203 cgrad            do l=1,3
3204 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3205 cgrad            enddo
3206 cgrad          enddo
3207           ggg(1)=facvdw*xj
3208           ggg(2)=facvdw*yj
3209           ggg(3)=facvdw*zj
3210 c          do k=1,3
3211 c            ghalf=0.5D0*ggg(k)
3212 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3213 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3214 c          enddo
3215 c 9/28/08 AL Gradient compotents will be summed only at the end
3216           do k=1,3
3217             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3218             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3219           enddo
3220 *
3221 * Loop over residues i+1 thru j-1.
3222 *
3223 cgrad          do k=i+1,j-1
3224 cgrad            do l=1,3
3225 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3226 cgrad            enddo
3227 cgrad          enddo
3228 #else
3229           facvdw=ev1+evdwij
3230           facel=el1+eesij
3231           fac1=fac
3232           fac=-3*rrmij*(facvdw+facvdw+facel)
3233           erij(1)=xj*rmij
3234           erij(2)=yj*rmij
3235           erij(3)=zj*rmij
3236 *
3237 * Radial derivatives. First process both termini of the fragment (i,j)
3238 *
3239           ggg(1)=fac*xj
3240           ggg(2)=fac*yj
3241           ggg(3)=fac*zj
3242 c          do k=1,3
3243 c            ghalf=0.5D0*ggg(k)
3244 c            gelc(k,i)=gelc(k,i)+ghalf
3245 c            gelc(k,j)=gelc(k,j)+ghalf
3246 c          enddo
3247 c 9/28/08 AL Gradient compotents will be summed only at the end
3248           do k=1,3
3249             gelc_long(k,j)=gelc(k,j)+ggg(k)
3250             gelc_long(k,i)=gelc(k,i)-ggg(k)
3251           enddo
3252 *
3253 * Loop over residues i+1 thru j-1.
3254 *
3255 cgrad          do k=i+1,j-1
3256 cgrad            do l=1,3
3257 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3258 cgrad            enddo
3259 cgrad          enddo
3260 c 9/28/08 AL Gradient compotents will be summed only at the end
3261           ggg(1)=facvdw*xj
3262           ggg(2)=facvdw*yj
3263           ggg(3)=facvdw*zj
3264           do k=1,3
3265             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3266             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3267           enddo
3268 #endif
3269 *
3270 * Angular part
3271 *
3272           ecosa=2.0D0*fac3*fac1+fac4
3273           fac4=-3.0D0*fac4
3274           fac3=-6.0D0*fac3
3275           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3276           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3277           do k=1,3
3278             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3279             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3280           enddo
3281 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3282 cd   &          (dcosg(k),k=1,3)
3283           do k=1,3
3284             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3285           enddo
3286 c          do k=1,3
3287 c            ghalf=0.5D0*ggg(k)
3288 c            gelc(k,i)=gelc(k,i)+ghalf
3289 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3290 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3291 c            gelc(k,j)=gelc(k,j)+ghalf
3292 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3293 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3294 c          enddo
3295 cgrad          do k=i+1,j-1
3296 cgrad            do l=1,3
3297 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3298 cgrad            enddo
3299 cgrad          enddo
3300           do k=1,3
3301             gelc(k,i)=gelc(k,i)
3302      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3303      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3304             gelc(k,j)=gelc(k,j)
3305      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3306      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3307             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3308             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3309           enddo
3310           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3311      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3312      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3313 C
3314 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3315 C   energy of a peptide unit is assumed in the form of a second-order
3316 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3317 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3318 C   are computed for EVERY pair of non-contiguous peptide groups.
3319 C
3320           if (j.lt.nres-1) then
3321             j1=j+1
3322             j2=j-1
3323           else
3324             j1=j-1
3325             j2=j-2
3326           endif
3327           kkk=0
3328           do k=1,2
3329             do l=1,2
3330               kkk=kkk+1
3331               muij(kkk)=mu(k,i)*mu(l,j)
3332             enddo
3333           enddo
3334 cd         write (iout,*) 'EELEC: i',i,' j',j
3335 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3336 cd          write(iout,*) 'muij',muij
3337           ury=scalar(uy(1,i),erij)
3338           urz=scalar(uz(1,i),erij)
3339           vry=scalar(uy(1,j),erij)
3340           vrz=scalar(uz(1,j),erij)
3341           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3342           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3343           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3344           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3345           fac=dsqrt(-ael6i)*r3ij
3346           a22=a22*fac
3347           a23=a23*fac
3348           a32=a32*fac
3349           a33=a33*fac
3350 cd          write (iout,'(4i5,4f10.5)')
3351 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3352 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3353 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3354 cd     &      uy(:,j),uz(:,j)
3355 cd          write (iout,'(4f10.5)')
3356 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3357 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3358 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3359 cd           write (iout,'(9f10.5/)')
3360 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3361 C Derivatives of the elements of A in virtual-bond vectors
3362           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3363           do k=1,3
3364             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3365             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3366             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3367             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3368             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3369             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3370             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3371             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3372             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3373             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3374             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3375             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3376           enddo
3377 C Compute radial contributions to the gradient
3378           facr=-3.0d0*rrmij
3379           a22der=a22*facr
3380           a23der=a23*facr
3381           a32der=a32*facr
3382           a33der=a33*facr
3383           agg(1,1)=a22der*xj
3384           agg(2,1)=a22der*yj
3385           agg(3,1)=a22der*zj
3386           agg(1,2)=a23der*xj
3387           agg(2,2)=a23der*yj
3388           agg(3,2)=a23der*zj
3389           agg(1,3)=a32der*xj
3390           agg(2,3)=a32der*yj
3391           agg(3,3)=a32der*zj
3392           agg(1,4)=a33der*xj
3393           agg(2,4)=a33der*yj
3394           agg(3,4)=a33der*zj
3395 C Add the contributions coming from er
3396           fac3=-3.0d0*fac
3397           do k=1,3
3398             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3399             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3400             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3401             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3402           enddo
3403           do k=1,3
3404 C Derivatives in DC(i)
3405 cgrad            ghalf1=0.5d0*agg(k,1)
3406 cgrad            ghalf2=0.5d0*agg(k,2)
3407 cgrad            ghalf3=0.5d0*agg(k,3)
3408 cgrad            ghalf4=0.5d0*agg(k,4)
3409             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3410      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3411             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3412      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3413             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3414      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3415             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3416      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3417 C Derivatives in DC(i+1)
3418             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3419      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3420             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3421      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3422             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3423      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3424             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3425      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3426 C Derivatives in DC(j)
3427             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3428      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3429             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3430      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3431             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3432      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3433             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3434      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3435 C Derivatives in DC(j+1) or DC(nres-1)
3436             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3437      &      -3.0d0*vryg(k,3)*ury)
3438             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3439      &      -3.0d0*vrzg(k,3)*ury)
3440             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3441      &      -3.0d0*vryg(k,3)*urz)
3442             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3443      &      -3.0d0*vrzg(k,3)*urz)
3444 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3445 cgrad              do l=1,4
3446 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3447 cgrad              enddo
3448 cgrad            endif
3449           enddo
3450           acipa(1,1)=a22
3451           acipa(1,2)=a23
3452           acipa(2,1)=a32
3453           acipa(2,2)=a33
3454           a22=-a22
3455           a23=-a23
3456           do l=1,2
3457             do k=1,3
3458               agg(k,l)=-agg(k,l)
3459               aggi(k,l)=-aggi(k,l)
3460               aggi1(k,l)=-aggi1(k,l)
3461               aggj(k,l)=-aggj(k,l)
3462               aggj1(k,l)=-aggj1(k,l)
3463             enddo
3464           enddo
3465           if (j.lt.nres-1) then
3466             a22=-a22
3467             a32=-a32
3468             do l=1,3,2
3469               do k=1,3
3470                 agg(k,l)=-agg(k,l)
3471                 aggi(k,l)=-aggi(k,l)
3472                 aggi1(k,l)=-aggi1(k,l)
3473                 aggj(k,l)=-aggj(k,l)
3474                 aggj1(k,l)=-aggj1(k,l)
3475               enddo
3476             enddo
3477           else
3478             a22=-a22
3479             a23=-a23
3480             a32=-a32
3481             a33=-a33
3482             do l=1,4
3483               do k=1,3
3484                 agg(k,l)=-agg(k,l)
3485                 aggi(k,l)=-aggi(k,l)
3486                 aggi1(k,l)=-aggi1(k,l)
3487                 aggj(k,l)=-aggj(k,l)
3488                 aggj1(k,l)=-aggj1(k,l)
3489               enddo
3490             enddo
3491           endif
3492           ENDIF ! WCORR
3493           IF (wel_loc.gt.0.0d0) THEN
3494 C Contribution to the local-electrostatic energy coming from the i-j pair
3495           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3496      &     +a33*muij(4)
3497 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3498
3499           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3500      &            'eelloc',i,j,eel_loc_ij
3501
3502           eel_loc=eel_loc+eel_loc_ij
3503 C Partial derivatives in virtual-bond dihedral angles gamma
3504           if (i.gt.1)
3505      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3506      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3507      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3508           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3509      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3510      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3511 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3512           do l=1,3
3513             ggg(l)=agg(l,1)*muij(1)+
3514      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3515             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3516             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3517 cgrad            ghalf=0.5d0*ggg(l)
3518 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3519 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3520           enddo
3521 cgrad          do k=i+1,j2
3522 cgrad            do l=1,3
3523 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3524 cgrad            enddo
3525 cgrad          enddo
3526 C Remaining derivatives of eello
3527           do l=1,3
3528             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3529      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3530             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3531      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3532             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3533      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3534             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3535      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3536           enddo
3537           ENDIF
3538 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3539 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3540           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3541      &       .and. num_conti.le.maxconts) then
3542 c            write (iout,*) i,j," entered corr"
3543 C
3544 C Calculate the contact function. The ith column of the array JCONT will
3545 C contain the numbers of atoms that make contacts with the atom I (of numbers
3546 C greater than I). The arrays FACONT and GACONT will contain the values of
3547 C the contact function and its derivative.
3548 c           r0ij=1.02D0*rpp(iteli,itelj)
3549 c           r0ij=1.11D0*rpp(iteli,itelj)
3550             r0ij=2.20D0*rpp(iteli,itelj)
3551 c           r0ij=1.55D0*rpp(iteli,itelj)
3552             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3553             if (fcont.gt.0.0D0) then
3554               num_conti=num_conti+1
3555               if (num_conti.gt.maxconts) then
3556                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3557      &                         ' will skip next contacts for this conf.'
3558               else
3559                 jcont_hb(num_conti,i)=j
3560 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3561 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3562                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3563      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3564 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3565 C  terms.
3566                 d_cont(num_conti,i)=rij
3567 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3568 C     --- Electrostatic-interaction matrix ---
3569                 a_chuj(1,1,num_conti,i)=a22
3570                 a_chuj(1,2,num_conti,i)=a23
3571                 a_chuj(2,1,num_conti,i)=a32
3572                 a_chuj(2,2,num_conti,i)=a33
3573 C     --- Gradient of rij
3574                 do kkk=1,3
3575                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3576                 enddo
3577                 kkll=0
3578                 do k=1,2
3579                   do l=1,2
3580                     kkll=kkll+1
3581                     do m=1,3
3582                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3583                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3584                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3585                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3586                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3587                     enddo
3588                   enddo
3589                 enddo
3590                 ENDIF
3591                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3592 C Calculate contact energies
3593                 cosa4=4.0D0*cosa
3594                 wij=cosa-3.0D0*cosb*cosg
3595                 cosbg1=cosb+cosg
3596                 cosbg2=cosb-cosg
3597 c               fac3=dsqrt(-ael6i)/r0ij**3
3598                 fac3=dsqrt(-ael6i)*r3ij
3599 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3600                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3601                 if (ees0tmp.gt.0) then
3602                   ees0pij=dsqrt(ees0tmp)
3603                 else
3604                   ees0pij=0
3605                 endif
3606 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3607                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3608                 if (ees0tmp.gt.0) then
3609                   ees0mij=dsqrt(ees0tmp)
3610                 else
3611                   ees0mij=0
3612                 endif
3613 c               ees0mij=0.0D0
3614                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3615                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3616 C Diagnostics. Comment out or remove after debugging!
3617 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3618 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3619 c               ees0m(num_conti,i)=0.0D0
3620 C End diagnostics.
3621 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3622 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3623 C Angular derivatives of the contact function
3624                 ees0pij1=fac3/ees0pij
3625                 ees0mij1=fac3/ees0mij
3626                 fac3p=-3.0D0*fac3*rrmij
3627                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3628                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3629 c               ees0mij1=0.0D0
3630                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3631                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3632                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3633                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3634                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3635                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3636                 ecosap=ecosa1+ecosa2
3637                 ecosbp=ecosb1+ecosb2
3638                 ecosgp=ecosg1+ecosg2
3639                 ecosam=ecosa1-ecosa2
3640                 ecosbm=ecosb1-ecosb2
3641                 ecosgm=ecosg1-ecosg2
3642 C Diagnostics
3643 c               ecosap=ecosa1
3644 c               ecosbp=ecosb1
3645 c               ecosgp=ecosg1
3646 c               ecosam=0.0D0
3647 c               ecosbm=0.0D0
3648 c               ecosgm=0.0D0
3649 C End diagnostics
3650                 facont_hb(num_conti,i)=fcont
3651                 fprimcont=fprimcont/rij
3652 cd              facont_hb(num_conti,i)=1.0D0
3653 C Following line is for diagnostics.
3654 cd              fprimcont=0.0D0
3655                 do k=1,3
3656                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3657                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3658                 enddo
3659                 do k=1,3
3660                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3661                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3662                 enddo
3663                 gggp(1)=gggp(1)+ees0pijp*xj
3664                 gggp(2)=gggp(2)+ees0pijp*yj
3665                 gggp(3)=gggp(3)+ees0pijp*zj
3666                 gggm(1)=gggm(1)+ees0mijp*xj
3667                 gggm(2)=gggm(2)+ees0mijp*yj
3668                 gggm(3)=gggm(3)+ees0mijp*zj
3669 C Derivatives due to the contact function
3670                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3671                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3672                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3673                 do k=1,3
3674 c
3675 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3676 c          following the change of gradient-summation algorithm.
3677 c
3678 cgrad                  ghalfp=0.5D0*gggp(k)
3679 cgrad                  ghalfm=0.5D0*gggm(k)
3680                   gacontp_hb1(k,num_conti,i)=!ghalfp
3681      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3682      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3683                   gacontp_hb2(k,num_conti,i)=!ghalfp
3684      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3685      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3686                   gacontp_hb3(k,num_conti,i)=gggp(k)
3687                   gacontm_hb1(k,num_conti,i)=!ghalfm
3688      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3689      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3690                   gacontm_hb2(k,num_conti,i)=!ghalfm
3691      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3692      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3693                   gacontm_hb3(k,num_conti,i)=gggm(k)
3694                 enddo
3695 C Diagnostics. Comment out or remove after debugging!
3696 cdiag           do k=1,3
3697 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3698 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3699 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3700 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3701 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3702 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3703 cdiag           enddo
3704               ENDIF ! wcorr
3705               endif  ! num_conti.le.maxconts
3706             endif  ! fcont.gt.0
3707           endif    ! j.gt.i+1
3708           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3709             do k=1,4
3710               do l=1,3
3711                 ghalf=0.5d0*agg(l,k)
3712                 aggi(l,k)=aggi(l,k)+ghalf
3713                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3714                 aggj(l,k)=aggj(l,k)+ghalf
3715               enddo
3716             enddo
3717             if (j.eq.nres-1 .and. i.lt.j-2) then
3718               do k=1,4
3719                 do l=1,3
3720                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3721                 enddo
3722               enddo
3723             endif
3724           endif
3725 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3726       return
3727       end
3728 C-----------------------------------------------------------------------------
3729       subroutine eturn3(i,eello_turn3)
3730 C Third- and fourth-order contributions from turns
3731       implicit real*8 (a-h,o-z)
3732       include 'DIMENSIONS'
3733       include 'COMMON.IOUNITS'
3734       include 'COMMON.GEO'
3735       include 'COMMON.VAR'
3736       include 'COMMON.LOCAL'
3737       include 'COMMON.CHAIN'
3738       include 'COMMON.DERIV'
3739       include 'COMMON.INTERACT'
3740       include 'COMMON.CONTACTS'
3741       include 'COMMON.TORSION'
3742       include 'COMMON.VECTORS'
3743       include 'COMMON.FFIELD'
3744       include 'COMMON.CONTROL'
3745       dimension ggg(3)
3746       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3747      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3748      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3749       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3750      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3751       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3752      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3753      &    num_conti,j1,j2
3754       j=i+2
3755 c      write (iout,*) "eturn3",i,j,j1,j2
3756       a_temp(1,1)=a22
3757       a_temp(1,2)=a23
3758       a_temp(2,1)=a32
3759       a_temp(2,2)=a33
3760 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3761 C
3762 C               Third-order contributions
3763 C
3764 C                 (i+2)o----(i+3)
3765 C                      | |
3766 C                      | |
3767 C                 (i+1)o----i
3768 C
3769 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3770 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3771         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3772         call transpose2(auxmat(1,1),auxmat1(1,1))
3773         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3774         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3775         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3776      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3777 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3778 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3779 cd     &    ' eello_turn3_num',4*eello_turn3_num
3780 C Derivatives in gamma(i)
3781         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3782         call transpose2(auxmat2(1,1),auxmat3(1,1))
3783         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3784         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3785 C Derivatives in gamma(i+1)
3786         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3787         call transpose2(auxmat2(1,1),auxmat3(1,1))
3788         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3789         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3790      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3791 C Cartesian derivatives
3792         do l=1,3
3793 c            ghalf1=0.5d0*agg(l,1)
3794 c            ghalf2=0.5d0*agg(l,2)
3795 c            ghalf3=0.5d0*agg(l,3)
3796 c            ghalf4=0.5d0*agg(l,4)
3797           a_temp(1,1)=aggi(l,1)!+ghalf1
3798           a_temp(1,2)=aggi(l,2)!+ghalf2
3799           a_temp(2,1)=aggi(l,3)!+ghalf3
3800           a_temp(2,2)=aggi(l,4)!+ghalf4
3801           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3802           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3803      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3804           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3805           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3806           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3807           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3808           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3809           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3810      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3811           a_temp(1,1)=aggj(l,1)!+ghalf1
3812           a_temp(1,2)=aggj(l,2)!+ghalf2
3813           a_temp(2,1)=aggj(l,3)!+ghalf3
3814           a_temp(2,2)=aggj(l,4)!+ghalf4
3815           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3816           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3817      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3818           a_temp(1,1)=aggj1(l,1)
3819           a_temp(1,2)=aggj1(l,2)
3820           a_temp(2,1)=aggj1(l,3)
3821           a_temp(2,2)=aggj1(l,4)
3822           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3823           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3824      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3825         enddo
3826       return
3827       end
3828 C-------------------------------------------------------------------------------
3829       subroutine eturn4(i,eello_turn4)
3830 C Third- and fourth-order contributions from turns
3831       implicit real*8 (a-h,o-z)
3832       include 'DIMENSIONS'
3833       include 'COMMON.IOUNITS'
3834       include 'COMMON.GEO'
3835       include 'COMMON.VAR'
3836       include 'COMMON.LOCAL'
3837       include 'COMMON.CHAIN'
3838       include 'COMMON.DERIV'
3839       include 'COMMON.INTERACT'
3840       include 'COMMON.CONTACTS'
3841       include 'COMMON.TORSION'
3842       include 'COMMON.VECTORS'
3843       include 'COMMON.FFIELD'
3844       include 'COMMON.CONTROL'
3845       dimension ggg(3)
3846       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3847      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3848      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3849       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3850      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3851       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3852      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3853      &    num_conti,j1,j2
3854       j=i+3
3855 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3856 C
3857 C               Fourth-order contributions
3858 C
3859 C                 (i+3)o----(i+4)
3860 C                     /  |
3861 C               (i+2)o   |
3862 C                     \  |
3863 C                 (i+1)o----i
3864 C
3865 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3866 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3867 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3868         a_temp(1,1)=a22
3869         a_temp(1,2)=a23
3870         a_temp(2,1)=a32
3871         a_temp(2,2)=a33
3872         iti1=itortyp(itype(i+1))
3873         iti2=itortyp(itype(i+2))
3874         iti3=itortyp(itype(i+3))
3875 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3876         call transpose2(EUg(1,1,i+1),e1t(1,1))
3877         call transpose2(Eug(1,1,i+2),e2t(1,1))
3878         call transpose2(Eug(1,1,i+3),e3t(1,1))
3879         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3880         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3881         s1=scalar2(b1(1,iti2),auxvec(1))
3882         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3883         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3884         s2=scalar2(b1(1,iti1),auxvec(1))
3885         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3886         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3887         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3888         eello_turn4=eello_turn4-(s1+s2+s3)
3889         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3890      &      'eturn4',i,j,-(s1+s2+s3)
3891 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3892 cd     &    ' eello_turn4_num',8*eello_turn4_num
3893 C Derivatives in gamma(i)
3894         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3895         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3896         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3897         s1=scalar2(b1(1,iti2),auxvec(1))
3898         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3899         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3900         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3901 C Derivatives in gamma(i+1)
3902         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3903         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3904         s2=scalar2(b1(1,iti1),auxvec(1))
3905         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3906         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3907         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3908         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3909 C Derivatives in gamma(i+2)
3910         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3911         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3912         s1=scalar2(b1(1,iti2),auxvec(1))
3913         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3914         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3915         s2=scalar2(b1(1,iti1),auxvec(1))
3916         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3917         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3918         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3919         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3920 C Cartesian derivatives
3921 C Derivatives of this turn contributions in DC(i+2)
3922         if (j.lt.nres-1) then
3923           do l=1,3
3924             a_temp(1,1)=agg(l,1)
3925             a_temp(1,2)=agg(l,2)
3926             a_temp(2,1)=agg(l,3)
3927             a_temp(2,2)=agg(l,4)
3928             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3929             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3930             s1=scalar2(b1(1,iti2),auxvec(1))
3931             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3932             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3933             s2=scalar2(b1(1,iti1),auxvec(1))
3934             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3935             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3936             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3937             ggg(l)=-(s1+s2+s3)
3938             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3939           enddo
3940         endif
3941 C Remaining derivatives of this turn contribution
3942         do l=1,3
3943           a_temp(1,1)=aggi(l,1)
3944           a_temp(1,2)=aggi(l,2)
3945           a_temp(2,1)=aggi(l,3)
3946           a_temp(2,2)=aggi(l,4)
3947           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3948           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3949           s1=scalar2(b1(1,iti2),auxvec(1))
3950           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3951           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3952           s2=scalar2(b1(1,iti1),auxvec(1))
3953           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3954           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3955           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3956           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3957           a_temp(1,1)=aggi1(l,1)
3958           a_temp(1,2)=aggi1(l,2)
3959           a_temp(2,1)=aggi1(l,3)
3960           a_temp(2,2)=aggi1(l,4)
3961           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3962           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3963           s1=scalar2(b1(1,iti2),auxvec(1))
3964           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3965           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3966           s2=scalar2(b1(1,iti1),auxvec(1))
3967           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3968           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3969           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3970           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3971           a_temp(1,1)=aggj(l,1)
3972           a_temp(1,2)=aggj(l,2)
3973           a_temp(2,1)=aggj(l,3)
3974           a_temp(2,2)=aggj(l,4)
3975           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3976           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3977           s1=scalar2(b1(1,iti2),auxvec(1))
3978           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3979           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3980           s2=scalar2(b1(1,iti1),auxvec(1))
3981           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3982           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3983           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3984           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3985           a_temp(1,1)=aggj1(l,1)
3986           a_temp(1,2)=aggj1(l,2)
3987           a_temp(2,1)=aggj1(l,3)
3988           a_temp(2,2)=aggj1(l,4)
3989           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3990           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3991           s1=scalar2(b1(1,iti2),auxvec(1))
3992           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3993           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3994           s2=scalar2(b1(1,iti1),auxvec(1))
3995           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3996           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3997           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3998 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3999           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4000         enddo
4001       return
4002       end
4003 C-----------------------------------------------------------------------------
4004       subroutine vecpr(u,v,w)
4005       implicit real*8(a-h,o-z)
4006       dimension u(3),v(3),w(3)
4007       w(1)=u(2)*v(3)-u(3)*v(2)
4008       w(2)=-u(1)*v(3)+u(3)*v(1)
4009       w(3)=u(1)*v(2)-u(2)*v(1)
4010       return
4011       end
4012 C-----------------------------------------------------------------------------
4013       subroutine unormderiv(u,ugrad,unorm,ungrad)
4014 C This subroutine computes the derivatives of a normalized vector u, given
4015 C the derivatives computed without normalization conditions, ugrad. Returns
4016 C ungrad.
4017       implicit none
4018       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4019       double precision vec(3)
4020       double precision scalar
4021       integer i,j
4022 c      write (2,*) 'ugrad',ugrad
4023 c      write (2,*) 'u',u
4024       do i=1,3
4025         vec(i)=scalar(ugrad(1,i),u(1))
4026       enddo
4027 c      write (2,*) 'vec',vec
4028       do i=1,3
4029         do j=1,3
4030           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4031         enddo
4032       enddo
4033 c      write (2,*) 'ungrad',ungrad
4034       return
4035       end
4036 C-----------------------------------------------------------------------------
4037       subroutine escp_soft_sphere(evdw2,evdw2_14)
4038 C
4039 C This subroutine calculates the excluded-volume interaction energy between
4040 C peptide-group centers and side chains and its gradient in virtual-bond and
4041 C side-chain vectors.
4042 C
4043       implicit real*8 (a-h,o-z)
4044       include 'DIMENSIONS'
4045       include 'COMMON.GEO'
4046       include 'COMMON.VAR'
4047       include 'COMMON.LOCAL'
4048       include 'COMMON.CHAIN'
4049       include 'COMMON.DERIV'
4050       include 'COMMON.INTERACT'
4051       include 'COMMON.FFIELD'
4052       include 'COMMON.IOUNITS'
4053       include 'COMMON.CONTROL'
4054       dimension ggg(3)
4055       evdw2=0.0D0
4056       evdw2_14=0.0d0
4057       r0_scp=4.5d0
4058 cd    print '(a)','Enter ESCP'
4059 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4060       do i=iatscp_s,iatscp_e
4061         iteli=itel(i)
4062         xi=0.5D0*(c(1,i)+c(1,i+1))
4063         yi=0.5D0*(c(2,i)+c(2,i+1))
4064         zi=0.5D0*(c(3,i)+c(3,i+1))
4065
4066         do iint=1,nscp_gr(i)
4067
4068         do j=iscpstart(i,iint),iscpend(i,iint)
4069           itypj=itype(j)
4070 C Uncomment following three lines for SC-p interactions
4071 c         xj=c(1,nres+j)-xi
4072 c         yj=c(2,nres+j)-yi
4073 c         zj=c(3,nres+j)-zi
4074 C Uncomment following three lines for Ca-p interactions
4075           xj=c(1,j)-xi
4076           yj=c(2,j)-yi
4077           zj=c(3,j)-zi
4078           rij=xj*xj+yj*yj+zj*zj
4079           r0ij=r0_scp
4080           r0ijsq=r0ij*r0ij
4081           if (rij.lt.r0ijsq) then
4082             evdwij=0.25d0*(rij-r0ijsq)**2
4083             fac=rij-r0ijsq
4084           else
4085             evdwij=0.0d0
4086             fac=0.0d0
4087           endif
4088           evdw2=evdw2+evdwij
4089 C
4090 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4091 C
4092           ggg(1)=xj*fac
4093           ggg(2)=yj*fac
4094           ggg(3)=zj*fac
4095 cgrad          if (j.lt.i) then
4096 cd          write (iout,*) 'j<i'
4097 C Uncomment following three lines for SC-p interactions
4098 c           do k=1,3
4099 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4100 c           enddo
4101 cgrad          else
4102 cd          write (iout,*) 'j>i'
4103 cgrad            do k=1,3
4104 cgrad              ggg(k)=-ggg(k)
4105 C Uncomment following line for SC-p interactions
4106 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4107 cgrad            enddo
4108 cgrad          endif
4109 cgrad          do k=1,3
4110 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4111 cgrad          enddo
4112 cgrad          kstart=min0(i+1,j)
4113 cgrad          kend=max0(i-1,j-1)
4114 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4115 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4116 cgrad          do k=kstart,kend
4117 cgrad            do l=1,3
4118 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4119 cgrad            enddo
4120 cgrad          enddo
4121           do k=1,3
4122             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4123             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4124           enddo
4125         enddo
4126
4127         enddo ! iint
4128       enddo ! i
4129       return
4130       end
4131 C-----------------------------------------------------------------------------
4132       subroutine escp(evdw2,evdw2_14)
4133 C
4134 C This subroutine calculates the excluded-volume interaction energy between
4135 C peptide-group centers and side chains and its gradient in virtual-bond and
4136 C side-chain vectors.
4137 C
4138       implicit real*8 (a-h,o-z)
4139       include 'DIMENSIONS'
4140       include 'COMMON.GEO'
4141       include 'COMMON.VAR'
4142       include 'COMMON.LOCAL'
4143       include 'COMMON.CHAIN'
4144       include 'COMMON.DERIV'
4145       include 'COMMON.INTERACT'
4146       include 'COMMON.FFIELD'
4147       include 'COMMON.IOUNITS'
4148       include 'COMMON.CONTROL'
4149       dimension ggg(3)
4150       evdw2=0.0D0
4151       evdw2_14=0.0d0
4152 cd    print '(a)','Enter ESCP'
4153 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4154       do i=iatscp_s,iatscp_e
4155         iteli=itel(i)
4156         xi=0.5D0*(c(1,i)+c(1,i+1))
4157         yi=0.5D0*(c(2,i)+c(2,i+1))
4158         zi=0.5D0*(c(3,i)+c(3,i+1))
4159
4160         do iint=1,nscp_gr(i)
4161
4162         do j=iscpstart(i,iint),iscpend(i,iint)
4163           itypj=itype(j)
4164 C Uncomment following three lines for SC-p interactions
4165 c         xj=c(1,nres+j)-xi
4166 c         yj=c(2,nres+j)-yi
4167 c         zj=c(3,nres+j)-zi
4168 C Uncomment following three lines for Ca-p interactions
4169           xj=c(1,j)-xi
4170           yj=c(2,j)-yi
4171           zj=c(3,j)-zi
4172           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4173           fac=rrij**expon2
4174           e1=fac*fac*aad(itypj,iteli)
4175           e2=fac*bad(itypj,iteli)
4176           if (iabs(j-i) .le. 2) then
4177             e1=scal14*e1
4178             e2=scal14*e2
4179             evdw2_14=evdw2_14+e1+e2
4180           endif
4181           evdwij=e1+e2
4182           evdw2=evdw2+evdwij
4183           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4184      &        'evdw2',i,j,evdwij
4185 C
4186 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4187 C
4188           fac=-(evdwij+e1)*rrij
4189           ggg(1)=xj*fac
4190           ggg(2)=yj*fac
4191           ggg(3)=zj*fac
4192 cgrad          if (j.lt.i) then
4193 cd          write (iout,*) 'j<i'
4194 C Uncomment following three lines for SC-p interactions
4195 c           do k=1,3
4196 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4197 c           enddo
4198 cgrad          else
4199 cd          write (iout,*) 'j>i'
4200 cgrad            do k=1,3
4201 cgrad              ggg(k)=-ggg(k)
4202 C Uncomment following line for SC-p interactions
4203 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4204 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4205 cgrad            enddo
4206 cgrad          endif
4207 cgrad          do k=1,3
4208 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4209 cgrad          enddo
4210 cgrad          kstart=min0(i+1,j)
4211 cgrad          kend=max0(i-1,j-1)
4212 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4213 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4214 cgrad          do k=kstart,kend
4215 cgrad            do l=1,3
4216 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4217 cgrad            enddo
4218 cgrad          enddo
4219           do k=1,3
4220             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4221             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4222           enddo
4223         enddo
4224
4225         enddo ! iint
4226       enddo ! i
4227       do i=1,nct
4228         do j=1,3
4229           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4230           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4231           gradx_scp(j,i)=expon*gradx_scp(j,i)
4232         enddo
4233       enddo
4234 C******************************************************************************
4235 C
4236 C                              N O T E !!!
4237 C
4238 C To save time the factor EXPON has been extracted from ALL components
4239 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4240 C use!
4241 C
4242 C******************************************************************************
4243       return
4244       end
4245 C--------------------------------------------------------------------------
4246       subroutine edis(ehpb)
4247 C
4248 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4249 C
4250       implicit real*8 (a-h,o-z)
4251       include 'DIMENSIONS'
4252       include 'COMMON.SBRIDGE'
4253       include 'COMMON.CHAIN'
4254       include 'COMMON.DERIV'
4255       include 'COMMON.VAR'
4256       include 'COMMON.INTERACT'
4257       include 'COMMON.IOUNITS'
4258       dimension ggg(3)
4259       ehpb=0.0D0
4260       write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4261       write(iout,*)'link_start=',link_start,' link_end=',link_end
4262       if (link_end.eq.0) return
4263       do i=link_start,link_end
4264 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4265 C CA-CA distance used in regularization of structure.
4266         ii=ihpb(i)
4267         jj=jhpb(i)
4268 C iii and jjj point to the residues for which the distance is assigned.
4269         if (ii.gt.nres) then
4270           iii=ii-nres
4271           jjj=jj-nres
4272         else
4273           iii=ii
4274           jjj=jj
4275         endif
4276 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4277 c     &    dhpb(i),dhpb1(i),forcon(i)
4278 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4279 C    distance and angle dependent SS bond potential.
4280         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4281           call ssbond_ene(iii,jjj,eij)
4282           ehpb=ehpb+2*eij
4283           write (iout,*) "eij",eij
4284         else if (ii.gt.nres .and. jj.gt.nres) then
4285 c Restraints from contact prediction
4286           dd=dist(ii,jj)
4287           if (dhpb1(i).gt.0.0d0) then
4288             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4289             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4290 c            write (iout,*) "beta nmr",
4291 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4292           else
4293             dd=dist(ii,jj)
4294             rdis=dd-dhpb(i)
4295 C Get the force constant corresponding to this distance.
4296             waga=forcon(i)
4297 C Calculate the contribution to energy.
4298             ehpb=ehpb+waga*rdis*rdis
4299 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4300 C
4301 C Evaluate gradient.
4302 C
4303             fac=waga*rdis/dd
4304           endif
4305           do j=1,3
4306             ggg(j)=fac*(c(j,jj)-c(j,ii))
4307           enddo
4308           do j=1,3
4309             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4310             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4311           enddo
4312           do k=1,3
4313             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4314             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4315           enddo
4316         else
4317 C Calculate the distance between the two points and its difference from the
4318 C target distance.
4319           dd=dist(ii,jj)
4320           if (dhpb1(i).gt.0.0d0) then
4321             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4322             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4323 c            write (iout,*) "alph nmr",
4324 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4325           else
4326             rdis=dd-dhpb(i)
4327 C Get the force constant corresponding to this distance.
4328             waga=forcon(i)
4329 C Calculate the contribution to energy.
4330             ehpb=ehpb+waga*rdis*rdis
4331 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4332 C
4333 C Evaluate gradient.
4334 C
4335             fac=waga*rdis/dd
4336           endif
4337 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4338 cd   &   ' waga=',waga,' fac=',fac
4339             do j=1,3
4340               ggg(j)=fac*(c(j,jj)-c(j,ii))
4341             enddo
4342 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4343 C If this is a SC-SC distance, we need to calculate the contributions to the
4344 C Cartesian gradient in the SC vectors (ghpbx).
4345           if (iii.lt.ii) then
4346           do j=1,3
4347             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4348             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4349           enddo
4350           endif
4351 cgrad        do j=iii,jjj-1
4352 cgrad          do k=1,3
4353 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4354 cgrad          enddo
4355 cgrad        enddo
4356           do k=1,3
4357             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4358             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4359           enddo
4360         endif
4361       enddo
4362       ehpb=0.5D0*ehpb
4363       return
4364       end
4365 C--------------------------------------------------------------------------
4366       subroutine ssbond_ene(i,j,eij)
4367 C
4368 C Calculate the distance and angle dependent SS-bond potential energy
4369 C using a free-energy function derived based on RHF/6-31G** ab initio
4370 C calculations of diethyl disulfide.
4371 C
4372 C A. Liwo and U. Kozlowska, 11/24/03
4373 C
4374       implicit real*8 (a-h,o-z)
4375       include 'DIMENSIONS'
4376       include 'COMMON.SBRIDGE'
4377       include 'COMMON.CHAIN'
4378       include 'COMMON.DERIV'
4379       include 'COMMON.LOCAL'
4380       include 'COMMON.INTERACT'
4381       include 'COMMON.VAR'
4382       include 'COMMON.IOUNITS'
4383       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4384       itypi=itype(i)
4385       xi=c(1,nres+i)
4386       yi=c(2,nres+i)
4387       zi=c(3,nres+i)
4388       dxi=dc_norm(1,nres+i)
4389       dyi=dc_norm(2,nres+i)
4390       dzi=dc_norm(3,nres+i)
4391 c      dsci_inv=dsc_inv(itypi)
4392       dsci_inv=vbld_inv(nres+i)
4393       itypj=itype(j)
4394 c      dscj_inv=dsc_inv(itypj)
4395       dscj_inv=vbld_inv(nres+j)
4396       xj=c(1,nres+j)-xi
4397       yj=c(2,nres+j)-yi
4398       zj=c(3,nres+j)-zi
4399       dxj=dc_norm(1,nres+j)
4400       dyj=dc_norm(2,nres+j)
4401       dzj=dc_norm(3,nres+j)
4402       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4403       rij=dsqrt(rrij)
4404       erij(1)=xj*rij
4405       erij(2)=yj*rij
4406       erij(3)=zj*rij
4407       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4408       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4409       om12=dxi*dxj+dyi*dyj+dzi*dzj
4410       do k=1,3
4411         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4412         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4413       enddo
4414       rij=1.0d0/rij
4415       deltad=rij-d0cm
4416       deltat1=1.0d0-om1
4417       deltat2=1.0d0+om2
4418       deltat12=om2-om1+2.0d0
4419       cosphi=om12-om1*om2
4420       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4421      &  +akct*deltad*deltat12+ebr
4422      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4423      &  +ss_depth
4424 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4425 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4426 c     &  " deltat12",deltat12," eij",eij
4427       ed=2*akcm*deltad+akct*deltat12
4428       pom1=akct*deltad
4429       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4430       eom1=-2*akth*deltat1-pom1-om2*pom2
4431       eom2= 2*akth*deltat2+pom1-om1*pom2
4432       eom12=pom2
4433       do k=1,3
4434         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4435         ghpbx(k,i)=ghpbx(k,i)-ggk
4436      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4437      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4438         ghpbx(k,j)=ghpbx(k,j)+ggk
4439      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4440      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4441         ghpbc(k,i)=ghpbc(k,i)-ggk
4442         ghpbc(k,j)=ghpbc(k,j)+ggk
4443       enddo
4444 C
4445 C Calculate the components of the gradient in DC and X
4446 C
4447 cgrad      do k=i,j-1
4448 cgrad        do l=1,3
4449 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4450 cgrad        enddo
4451 cgrad      enddo
4452       return
4453       end
4454 C--------------------------------------------------------------------------
4455       subroutine ebond(estr)
4456 c
4457 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4458 c
4459       implicit real*8 (a-h,o-z)
4460       include 'DIMENSIONS'
4461       include 'COMMON.LOCAL'
4462       include 'COMMON.GEO'
4463       include 'COMMON.INTERACT'
4464       include 'COMMON.DERIV'
4465       include 'COMMON.VAR'
4466       include 'COMMON.CHAIN'
4467       include 'COMMON.IOUNITS'
4468       include 'COMMON.NAMES'
4469       include 'COMMON.FFIELD'
4470       include 'COMMON.CONTROL'
4471       include 'COMMON.SETUP'
4472       double precision u(3),ud(3)
4473       estr=0.0d0
4474       do i=ibondp_start,ibondp_end
4475         diff = vbld(i)-vbldp0
4476 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4477         estr=estr+diff*diff
4478         do j=1,3
4479           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4480         enddo
4481 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4482       enddo
4483       estr=0.5d0*AKP*estr
4484 c
4485 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4486 c
4487       do i=ibond_start,ibond_end
4488         iti=itype(i)
4489         if (iti.ne.10) then
4490           nbi=nbondterm(iti)
4491           if (nbi.eq.1) then
4492             diff=vbld(i+nres)-vbldsc0(1,iti)
4493 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4494 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4495             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4496             do j=1,3
4497               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4498             enddo
4499           else
4500             do j=1,nbi
4501               diff=vbld(i+nres)-vbldsc0(j,iti)
4502               ud(j)=aksc(j,iti)*diff
4503               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4504             enddo
4505             uprod=u(1)
4506             do j=2,nbi
4507               uprod=uprod*u(j)
4508             enddo
4509             usum=0.0d0
4510             usumsqder=0.0d0
4511             do j=1,nbi
4512               uprod1=1.0d0
4513               uprod2=1.0d0
4514               do k=1,nbi
4515                 if (k.ne.j) then
4516                   uprod1=uprod1*u(k)
4517                   uprod2=uprod2*u(k)*u(k)
4518                 endif
4519               enddo
4520               usum=usum+uprod1
4521               usumsqder=usumsqder+ud(j)*uprod2
4522             enddo
4523             estr=estr+uprod/usum
4524             do j=1,3
4525              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4526             enddo
4527           endif
4528         endif
4529       enddo
4530       return
4531       end
4532 #ifdef CRYST_THETA
4533 C--------------------------------------------------------------------------
4534       subroutine ebend(etheta)
4535 C
4536 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4537 C angles gamma and its derivatives in consecutive thetas and gammas.
4538 C
4539       implicit real*8 (a-h,o-z)
4540       include 'DIMENSIONS'
4541       include 'COMMON.LOCAL'
4542       include 'COMMON.GEO'
4543       include 'COMMON.INTERACT'
4544       include 'COMMON.DERIV'
4545       include 'COMMON.VAR'
4546       include 'COMMON.CHAIN'
4547       include 'COMMON.IOUNITS'
4548       include 'COMMON.NAMES'
4549       include 'COMMON.FFIELD'
4550       include 'COMMON.CONTROL'
4551       common /calcthet/ term1,term2,termm,diffak,ratak,
4552      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4553      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4554       double precision y(2),z(2)
4555       delta=0.02d0*pi
4556 c      time11=dexp(-2*time)
4557 c      time12=1.0d0
4558       etheta=0.0D0
4559 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4560       do i=ithet_start,ithet_end
4561 C Zero the energy function and its derivative at 0 or pi.
4562         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4563         it=itype(i-1)
4564         if (i.gt.3) then
4565 #ifdef OSF
4566           phii=phi(i)
4567           if (phii.ne.phii) phii=150.0
4568 #else
4569           phii=phi(i)
4570 #endif
4571           y(1)=dcos(phii)
4572           y(2)=dsin(phii)
4573         else
4574           y(1)=0.0D0
4575           y(2)=0.0D0
4576         endif
4577         if (i.lt.nres) then
4578 #ifdef OSF
4579           phii1=phi(i+1)
4580           if (phii1.ne.phii1) phii1=150.0
4581           phii1=pinorm(phii1)
4582           z(1)=cos(phii1)
4583 #else
4584           phii1=phi(i+1)
4585           z(1)=dcos(phii1)
4586 #endif
4587           z(2)=dsin(phii1)
4588         else
4589           z(1)=0.0D0
4590           z(2)=0.0D0
4591         endif
4592 C Calculate the "mean" value of theta from the part of the distribution
4593 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4594 C In following comments this theta will be referred to as t_c.
4595         thet_pred_mean=0.0d0
4596         do k=1,2
4597           athetk=athet(k,it)
4598           bthetk=bthet(k,it)
4599           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4600         enddo
4601         dthett=thet_pred_mean*ssd
4602         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4603 C Derivatives of the "mean" values in gamma1 and gamma2.
4604         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4605         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4606         if (theta(i).gt.pi-delta) then
4607           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4608      &         E_tc0)
4609           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4610           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4611           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4612      &        E_theta)
4613           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4614      &        E_tc)
4615         else if (theta(i).lt.delta) then
4616           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4617           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4618           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4619      &        E_theta)
4620           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4621           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4622      &        E_tc)
4623         else
4624           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4625      &        E_theta,E_tc)
4626         endif
4627         etheta=etheta+ethetai
4628         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4629      &      'ebend',i,ethetai
4630         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4631         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4632         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4633       enddo
4634 C Ufff.... We've done all this!!!
4635       return
4636       end
4637 C---------------------------------------------------------------------------
4638       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4639      &     E_tc)
4640       implicit real*8 (a-h,o-z)
4641       include 'DIMENSIONS'
4642       include 'COMMON.LOCAL'
4643       include 'COMMON.IOUNITS'
4644       common /calcthet/ term1,term2,termm,diffak,ratak,
4645      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4646      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4647 C Calculate the contributions to both Gaussian lobes.
4648 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4649 C The "polynomial part" of the "standard deviation" of this part of
4650 C the distribution.
4651         sig=polthet(3,it)
4652         do j=2,0,-1
4653           sig=sig*thet_pred_mean+polthet(j,it)
4654         enddo
4655 C Derivative of the "interior part" of the "standard deviation of the"
4656 C gamma-dependent Gaussian lobe in t_c.
4657         sigtc=3*polthet(3,it)
4658         do j=2,1,-1
4659           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4660         enddo
4661         sigtc=sig*sigtc
4662 C Set the parameters of both Gaussian lobes of the distribution.
4663 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4664         fac=sig*sig+sigc0(it)
4665         sigcsq=fac+fac
4666         sigc=1.0D0/sigcsq
4667 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4668         sigsqtc=-4.0D0*sigcsq*sigtc
4669 c       print *,i,sig,sigtc,sigsqtc
4670 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4671         sigtc=-sigtc/(fac*fac)
4672 C Following variable is sigma(t_c)**(-2)
4673         sigcsq=sigcsq*sigcsq
4674         sig0i=sig0(it)
4675         sig0inv=1.0D0/sig0i**2
4676         delthec=thetai-thet_pred_mean
4677         delthe0=thetai-theta0i
4678         term1=-0.5D0*sigcsq*delthec*delthec
4679         term2=-0.5D0*sig0inv*delthe0*delthe0
4680 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4681 C NaNs in taking the logarithm. We extract the largest exponent which is added
4682 C to the energy (this being the log of the distribution) at the end of energy
4683 C term evaluation for this virtual-bond angle.
4684         if (term1.gt.term2) then
4685           termm=term1
4686           term2=dexp(term2-termm)
4687           term1=1.0d0
4688         else
4689           termm=term2
4690           term1=dexp(term1-termm)
4691           term2=1.0d0
4692         endif
4693 C The ratio between the gamma-independent and gamma-dependent lobes of
4694 C the distribution is a Gaussian function of thet_pred_mean too.
4695         diffak=gthet(2,it)-thet_pred_mean
4696         ratak=diffak/gthet(3,it)**2
4697         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4698 C Let's differentiate it in thet_pred_mean NOW.
4699         aktc=ak*ratak
4700 C Now put together the distribution terms to make complete distribution.
4701         termexp=term1+ak*term2
4702         termpre=sigc+ak*sig0i
4703 C Contribution of the bending energy from this theta is just the -log of
4704 C the sum of the contributions from the two lobes and the pre-exponential
4705 C factor. Simple enough, isn't it?
4706         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4707 C NOW the derivatives!!!
4708 C 6/6/97 Take into account the deformation.
4709         E_theta=(delthec*sigcsq*term1
4710      &       +ak*delthe0*sig0inv*term2)/termexp
4711         E_tc=((sigtc+aktc*sig0i)/termpre
4712      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4713      &       aktc*term2)/termexp)
4714       return
4715       end
4716 c-----------------------------------------------------------------------------
4717       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4718       implicit real*8 (a-h,o-z)
4719       include 'DIMENSIONS'
4720       include 'COMMON.LOCAL'
4721       include 'COMMON.IOUNITS'
4722       common /calcthet/ term1,term2,termm,diffak,ratak,
4723      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4724      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4725       delthec=thetai-thet_pred_mean
4726       delthe0=thetai-theta0i
4727 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4728       t3 = thetai-thet_pred_mean
4729       t6 = t3**2
4730       t9 = term1
4731       t12 = t3*sigcsq
4732       t14 = t12+t6*sigsqtc
4733       t16 = 1.0d0
4734       t21 = thetai-theta0i
4735       t23 = t21**2
4736       t26 = term2
4737       t27 = t21*t26
4738       t32 = termexp
4739       t40 = t32**2
4740       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4741      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4742      & *(-t12*t9-ak*sig0inv*t27)
4743       return
4744       end
4745 #else
4746 C--------------------------------------------------------------------------
4747       subroutine ebend(etheta)
4748 C
4749 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4750 C angles gamma and its derivatives in consecutive thetas and gammas.
4751 C ab initio-derived potentials from
4752 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4753 C
4754       implicit real*8 (a-h,o-z)
4755       include 'DIMENSIONS'
4756       include 'COMMON.LOCAL'
4757       include 'COMMON.GEO'
4758       include 'COMMON.INTERACT'
4759       include 'COMMON.DERIV'
4760       include 'COMMON.VAR'
4761       include 'COMMON.CHAIN'
4762       include 'COMMON.IOUNITS'
4763       include 'COMMON.NAMES'
4764       include 'COMMON.FFIELD'
4765       include 'COMMON.CONTROL'
4766       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4767      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4768      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4769      & sinph1ph2(maxdouble,maxdouble)
4770       logical lprn /.false./, lprn1 /.false./
4771       etheta=0.0D0
4772       do i=ithet_start,ithet_end
4773         dethetai=0.0d0
4774         dephii=0.0d0
4775         dephii1=0.0d0
4776         theti2=0.5d0*theta(i)
4777         ityp2=ithetyp(itype(i-1))
4778         do k=1,nntheterm
4779           coskt(k)=dcos(k*theti2)
4780           sinkt(k)=dsin(k*theti2)
4781         enddo
4782         if (i.gt.3) then
4783 #ifdef OSF
4784           phii=phi(i)
4785           if (phii.ne.phii) phii=150.0
4786 #else
4787           phii=phi(i)
4788 #endif
4789           ityp1=ithetyp(itype(i-2))
4790           do k=1,nsingle
4791             cosph1(k)=dcos(k*phii)
4792             sinph1(k)=dsin(k*phii)
4793           enddo
4794         else
4795           phii=0.0d0
4796           ityp1=nthetyp+1
4797           do k=1,nsingle
4798             cosph1(k)=0.0d0
4799             sinph1(k)=0.0d0
4800           enddo
4801         endif
4802         if (i.lt.nres) then
4803 #ifdef OSF
4804           phii1=phi(i+1)
4805           if (phii1.ne.phii1) phii1=150.0
4806           phii1=pinorm(phii1)
4807 #else
4808           phii1=phi(i+1)
4809 #endif
4810           ityp3=ithetyp(itype(i))
4811           do k=1,nsingle
4812             cosph2(k)=dcos(k*phii1)
4813             sinph2(k)=dsin(k*phii1)
4814           enddo
4815         else
4816           phii1=0.0d0
4817           ityp3=nthetyp+1
4818           do k=1,nsingle
4819             cosph2(k)=0.0d0
4820             sinph2(k)=0.0d0
4821           enddo
4822         endif
4823         ethetai=aa0thet(ityp1,ityp2,ityp3)
4824         do k=1,ndouble
4825           do l=1,k-1
4826             ccl=cosph1(l)*cosph2(k-l)
4827             ssl=sinph1(l)*sinph2(k-l)
4828             scl=sinph1(l)*cosph2(k-l)
4829             csl=cosph1(l)*sinph2(k-l)
4830             cosph1ph2(l,k)=ccl-ssl
4831             cosph1ph2(k,l)=ccl+ssl
4832             sinph1ph2(l,k)=scl+csl
4833             sinph1ph2(k,l)=scl-csl
4834           enddo
4835         enddo
4836         if (lprn) then
4837         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4838      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4839         write (iout,*) "coskt and sinkt"
4840         do k=1,nntheterm
4841           write (iout,*) k,coskt(k),sinkt(k)
4842         enddo
4843         endif
4844         do k=1,ntheterm
4845           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4846           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4847      &      *coskt(k)
4848           if (lprn)
4849      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4850      &     " ethetai",ethetai
4851         enddo
4852         if (lprn) then
4853         write (iout,*) "cosph and sinph"
4854         do k=1,nsingle
4855           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4856         enddo
4857         write (iout,*) "cosph1ph2 and sinph2ph2"
4858         do k=2,ndouble
4859           do l=1,k-1
4860             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4861      &         sinph1ph2(l,k),sinph1ph2(k,l)
4862           enddo
4863         enddo
4864         write(iout,*) "ethetai",ethetai
4865         endif
4866         do m=1,ntheterm2
4867           do k=1,nsingle
4868             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4869      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4870      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4871      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4872             ethetai=ethetai+sinkt(m)*aux
4873             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4874             dephii=dephii+k*sinkt(m)*(
4875      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4876      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4877             dephii1=dephii1+k*sinkt(m)*(
4878      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4879      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4880             if (lprn)
4881      &      write (iout,*) "m",m," k",k," bbthet",
4882      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4883      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4884      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4885      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4886           enddo
4887         enddo
4888         if (lprn)
4889      &  write(iout,*) "ethetai",ethetai
4890         do m=1,ntheterm3
4891           do k=2,ndouble
4892             do l=1,k-1
4893               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4894      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4895      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4896      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4897               ethetai=ethetai+sinkt(m)*aux
4898               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4899               dephii=dephii+l*sinkt(m)*(
4900      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4901      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4902      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4903      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4904               dephii1=dephii1+(k-l)*sinkt(m)*(
4905      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4906      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4907      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4908      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4909               if (lprn) then
4910               write (iout,*) "m",m," k",k," l",l," ffthet",
4911      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4912      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4913      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4914      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4915               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4916      &            cosph1ph2(k,l)*sinkt(m),
4917      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4918               endif
4919             enddo
4920           enddo
4921         enddo
4922 10      continue
4923         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4924      &   i,theta(i)*rad2deg,phii*rad2deg,
4925      &   phii1*rad2deg,ethetai
4926         etheta=etheta+ethetai
4927         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4928         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4929         gloc(nphi+i-2,icg)=wang*dethetai
4930       enddo
4931       return
4932       end
4933 #endif
4934 #ifdef CRYST_SC
4935 c-----------------------------------------------------------------------------
4936       subroutine esc(escloc)
4937 C Calculate the local energy of a side chain and its derivatives in the
4938 C corresponding virtual-bond valence angles THETA and the spherical angles
4939 C ALPHA and OMEGA.
4940       implicit real*8 (a-h,o-z)
4941       include 'DIMENSIONS'
4942       include 'COMMON.GEO'
4943       include 'COMMON.LOCAL'
4944       include 'COMMON.VAR'
4945       include 'COMMON.INTERACT'
4946       include 'COMMON.DERIV'
4947       include 'COMMON.CHAIN'
4948       include 'COMMON.IOUNITS'
4949       include 'COMMON.NAMES'
4950       include 'COMMON.FFIELD'
4951       include 'COMMON.CONTROL'
4952       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4953      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4954       common /sccalc/ time11,time12,time112,theti,it,nlobit
4955       delta=0.02d0*pi
4956       escloc=0.0D0
4957 c     write (iout,'(a)') 'ESC'
4958       do i=loc_start,loc_end
4959         it=itype(i)
4960         if (it.eq.10) goto 1
4961         nlobit=nlob(it)
4962 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4963 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4964         theti=theta(i+1)-pipol
4965         x(1)=dtan(theti)
4966         x(2)=alph(i)
4967         x(3)=omeg(i)
4968
4969         if (x(2).gt.pi-delta) then
4970           xtemp(1)=x(1)
4971           xtemp(2)=pi-delta
4972           xtemp(3)=x(3)
4973           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4974           xtemp(2)=pi
4975           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4976           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4977      &        escloci,dersc(2))
4978           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4979      &        ddersc0(1),dersc(1))
4980           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4981      &        ddersc0(3),dersc(3))
4982           xtemp(2)=pi-delta
4983           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4984           xtemp(2)=pi
4985           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4986           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4987      &            dersc0(2),esclocbi,dersc02)
4988           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4989      &            dersc12,dersc01)
4990           call splinthet(x(2),0.5d0*delta,ss,ssd)
4991           dersc0(1)=dersc01
4992           dersc0(2)=dersc02
4993           dersc0(3)=0.0d0
4994           do k=1,3
4995             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4996           enddo
4997           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4998 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4999 c    &             esclocbi,ss,ssd
5000           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5001 c         escloci=esclocbi
5002 c         write (iout,*) escloci
5003         else if (x(2).lt.delta) then
5004           xtemp(1)=x(1)
5005           xtemp(2)=delta
5006           xtemp(3)=x(3)
5007           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5008           xtemp(2)=0.0d0
5009           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5010           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5011      &        escloci,dersc(2))
5012           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5013      &        ddersc0(1),dersc(1))
5014           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5015      &        ddersc0(3),dersc(3))
5016           xtemp(2)=delta
5017           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5018           xtemp(2)=0.0d0
5019           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5020           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5021      &            dersc0(2),esclocbi,dersc02)
5022           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5023      &            dersc12,dersc01)
5024           dersc0(1)=dersc01
5025           dersc0(2)=dersc02
5026           dersc0(3)=0.0d0
5027           call splinthet(x(2),0.5d0*delta,ss,ssd)
5028           do k=1,3
5029             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5030           enddo
5031           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5032 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5033 c    &             esclocbi,ss,ssd
5034           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5035 c         write (iout,*) escloci
5036         else
5037           call enesc(x,escloci,dersc,ddummy,.false.)
5038         endif
5039
5040         escloc=escloc+escloci
5041         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5042      &     'escloc',i,escloci
5043 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5044
5045         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5046      &   wscloc*dersc(1)
5047         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5048         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5049     1   continue
5050       enddo
5051       return
5052       end
5053 C---------------------------------------------------------------------------
5054       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5055       implicit real*8 (a-h,o-z)
5056       include 'DIMENSIONS'
5057       include 'COMMON.GEO'
5058       include 'COMMON.LOCAL'
5059       include 'COMMON.IOUNITS'
5060       common /sccalc/ time11,time12,time112,theti,it,nlobit
5061       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5062       double precision contr(maxlob,-1:1)
5063       logical mixed
5064 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5065         escloc_i=0.0D0
5066         do j=1,3
5067           dersc(j)=0.0D0
5068           if (mixed) ddersc(j)=0.0d0
5069         enddo
5070         x3=x(3)
5071
5072 C Because of periodicity of the dependence of the SC energy in omega we have
5073 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5074 C To avoid underflows, first compute & store the exponents.
5075
5076         do iii=-1,1
5077
5078           x(3)=x3+iii*dwapi
5079
5080           do j=1,nlobit
5081             do k=1,3
5082               z(k)=x(k)-censc(k,j,it)
5083             enddo
5084             do k=1,3
5085               Axk=0.0D0
5086               do l=1,3
5087                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5088               enddo
5089               Ax(k,j,iii)=Axk
5090             enddo
5091             expfac=0.0D0
5092             do k=1,3
5093               expfac=expfac+Ax(k,j,iii)*z(k)
5094             enddo
5095             contr(j,iii)=expfac
5096           enddo ! j
5097
5098         enddo ! iii
5099
5100         x(3)=x3
5101 C As in the case of ebend, we want to avoid underflows in exponentiation and
5102 C subsequent NaNs and INFs in energy calculation.
5103 C Find the largest exponent
5104         emin=contr(1,-1)
5105         do iii=-1,1
5106           do j=1,nlobit
5107             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5108           enddo
5109         enddo
5110         emin=0.5D0*emin
5111 cd      print *,'it=',it,' emin=',emin
5112
5113 C Compute the contribution to SC energy and derivatives
5114         do iii=-1,1
5115
5116           do j=1,nlobit
5117 #ifdef OSF
5118             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5119             if(adexp.ne.adexp) adexp=1.0
5120             expfac=dexp(adexp)
5121 #else
5122             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5123 #endif
5124 cd          print *,'j=',j,' expfac=',expfac
5125             escloc_i=escloc_i+expfac
5126             do k=1,3
5127               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5128             enddo
5129             if (mixed) then
5130               do k=1,3,2
5131                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5132      &            +gaussc(k,2,j,it))*expfac
5133               enddo
5134             endif
5135           enddo
5136
5137         enddo ! iii
5138
5139         dersc(1)=dersc(1)/cos(theti)**2
5140         ddersc(1)=ddersc(1)/cos(theti)**2
5141         ddersc(3)=ddersc(3)
5142
5143         escloci=-(dlog(escloc_i)-emin)
5144         do j=1,3
5145           dersc(j)=dersc(j)/escloc_i
5146         enddo
5147         if (mixed) then
5148           do j=1,3,2
5149             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5150           enddo
5151         endif
5152       return
5153       end
5154 C------------------------------------------------------------------------------
5155       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5156       implicit real*8 (a-h,o-z)
5157       include 'DIMENSIONS'
5158       include 'COMMON.GEO'
5159       include 'COMMON.LOCAL'
5160       include 'COMMON.IOUNITS'
5161       common /sccalc/ time11,time12,time112,theti,it,nlobit
5162       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5163       double precision contr(maxlob)
5164       logical mixed
5165
5166       escloc_i=0.0D0
5167
5168       do j=1,3
5169         dersc(j)=0.0D0
5170       enddo
5171
5172       do j=1,nlobit
5173         do k=1,2
5174           z(k)=x(k)-censc(k,j,it)
5175         enddo
5176         z(3)=dwapi
5177         do k=1,3
5178           Axk=0.0D0
5179           do l=1,3
5180             Axk=Axk+gaussc(l,k,j,it)*z(l)
5181           enddo
5182           Ax(k,j)=Axk
5183         enddo
5184         expfac=0.0D0
5185         do k=1,3
5186           expfac=expfac+Ax(k,j)*z(k)
5187         enddo
5188         contr(j)=expfac
5189       enddo ! j
5190
5191 C As in the case of ebend, we want to avoid underflows in exponentiation and
5192 C subsequent NaNs and INFs in energy calculation.
5193 C Find the largest exponent
5194       emin=contr(1)
5195       do j=1,nlobit
5196         if (emin.gt.contr(j)) emin=contr(j)
5197       enddo
5198       emin=0.5D0*emin
5199
5200 C Compute the contribution to SC energy and derivatives
5201
5202       dersc12=0.0d0
5203       do j=1,nlobit
5204         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5205         escloc_i=escloc_i+expfac
5206         do k=1,2
5207           dersc(k)=dersc(k)+Ax(k,j)*expfac
5208         enddo
5209         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5210      &            +gaussc(1,2,j,it))*expfac
5211         dersc(3)=0.0d0
5212       enddo
5213
5214       dersc(1)=dersc(1)/cos(theti)**2
5215       dersc12=dersc12/cos(theti)**2
5216       escloci=-(dlog(escloc_i)-emin)
5217       do j=1,2
5218         dersc(j)=dersc(j)/escloc_i
5219       enddo
5220       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5221       return
5222       end
5223 #else
5224 c----------------------------------------------------------------------------------
5225       subroutine esc(escloc)
5226 C Calculate the local energy of a side chain and its derivatives in the
5227 C corresponding virtual-bond valence angles THETA and the spherical angles
5228 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5229 C added by Urszula Kozlowska. 07/11/2007
5230 C
5231       implicit real*8 (a-h,o-z)
5232       include 'DIMENSIONS'
5233       include 'COMMON.GEO'
5234       include 'COMMON.LOCAL'
5235       include 'COMMON.VAR'
5236       include 'COMMON.SCROT'
5237       include 'COMMON.INTERACT'
5238       include 'COMMON.DERIV'
5239       include 'COMMON.CHAIN'
5240       include 'COMMON.IOUNITS'
5241       include 'COMMON.NAMES'
5242       include 'COMMON.FFIELD'
5243       include 'COMMON.CONTROL'
5244       include 'COMMON.VECTORS'
5245       double precision x_prime(3),y_prime(3),z_prime(3)
5246      &    , sumene,dsc_i,dp2_i,x(65),
5247      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5248      &    de_dxx,de_dyy,de_dzz,de_dt
5249       double precision s1_t,s1_6_t,s2_t,s2_6_t
5250       double precision
5251      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5252      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5253      & dt_dCi(3),dt_dCi1(3)
5254       common /sccalc/ time11,time12,time112,theti,it,nlobit
5255       delta=0.02d0*pi
5256       escloc=0.0D0
5257       do i=loc_start,loc_end
5258         costtab(i+1) =dcos(theta(i+1))
5259         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5260         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5261         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5262         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5263         cosfac=dsqrt(cosfac2)
5264         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5265         sinfac=dsqrt(sinfac2)
5266         it=itype(i)
5267         if (it.eq.10) goto 1
5268 c
5269 C  Compute the axes of tghe local cartesian coordinates system; store in
5270 c   x_prime, y_prime and z_prime
5271 c
5272         do j=1,3
5273           x_prime(j) = 0.00
5274           y_prime(j) = 0.00
5275           z_prime(j) = 0.00
5276         enddo
5277 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5278 C     &   dc_norm(3,i+nres)
5279         do j = 1,3
5280           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5281           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5282         enddo
5283         do j = 1,3
5284           z_prime(j) = -uz(j,i-1)
5285         enddo
5286 c       write (2,*) "i",i
5287 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5288 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5289 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5290 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5291 c      & " xy",scalar(x_prime(1),y_prime(1)),
5292 c      & " xz",scalar(x_prime(1),z_prime(1)),
5293 c      & " yy",scalar(y_prime(1),y_prime(1)),
5294 c      & " yz",scalar(y_prime(1),z_prime(1)),
5295 c      & " zz",scalar(z_prime(1),z_prime(1))
5296 c
5297 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5298 C to local coordinate system. Store in xx, yy, zz.
5299 c
5300         xx=0.0d0
5301         yy=0.0d0
5302         zz=0.0d0
5303         do j = 1,3
5304           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5305           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5306           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5307         enddo
5308
5309         xxtab(i)=xx
5310         yytab(i)=yy
5311         zztab(i)=zz
5312 C
5313 C Compute the energy of the ith side cbain
5314 C
5315 c        write (2,*) "xx",xx," yy",yy," zz",zz
5316         it=itype(i)
5317         do j = 1,65
5318           x(j) = sc_parmin(j,it)
5319         enddo
5320 #ifdef CHECK_COORD
5321 Cc diagnostics - remove later
5322         xx1 = dcos(alph(2))
5323         yy1 = dsin(alph(2))*dcos(omeg(2))
5324         zz1 = -dsin(alph(2))*dsin(omeg(2))
5325         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5326      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5327      &    xx1,yy1,zz1
5328 C,"  --- ", xx_w,yy_w,zz_w
5329 c end diagnostics
5330 #endif
5331         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5332      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5333      &   + x(10)*yy*zz
5334         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5335      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5336      & + x(20)*yy*zz
5337         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5338      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5339      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5340      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5341      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5342      &  +x(40)*xx*yy*zz
5343         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5344      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5345      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5346      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5347      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5348      &  +x(60)*xx*yy*zz
5349         dsc_i   = 0.743d0+x(61)
5350         dp2_i   = 1.9d0+x(62)
5351         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5352      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5353         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5354      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5355         s1=(1+x(63))/(0.1d0 + dscp1)
5356         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5357         s2=(1+x(65))/(0.1d0 + dscp2)
5358         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5359         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5360      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5361 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5362 c     &   sumene4,
5363 c     &   dscp1,dscp2,sumene
5364 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5365         escloc = escloc + sumene
5366 c        write (2,*) "i",i," escloc",sumene,escloc
5367 #ifdef DEBUG
5368 C
5369 C This section to check the numerical derivatives of the energy of ith side
5370 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5371 C #define DEBUG in the code to turn it on.
5372 C
5373         write (2,*) "sumene               =",sumene
5374         aincr=1.0d-7
5375         xxsave=xx
5376         xx=xx+aincr
5377         write (2,*) xx,yy,zz
5378         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5379         de_dxx_num=(sumenep-sumene)/aincr
5380         xx=xxsave
5381         write (2,*) "xx+ sumene from enesc=",sumenep
5382         yysave=yy
5383         yy=yy+aincr
5384         write (2,*) xx,yy,zz
5385         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5386         de_dyy_num=(sumenep-sumene)/aincr
5387         yy=yysave
5388         write (2,*) "yy+ sumene from enesc=",sumenep
5389         zzsave=zz
5390         zz=zz+aincr
5391         write (2,*) xx,yy,zz
5392         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5393         de_dzz_num=(sumenep-sumene)/aincr
5394         zz=zzsave
5395         write (2,*) "zz+ sumene from enesc=",sumenep
5396         costsave=cost2tab(i+1)
5397         sintsave=sint2tab(i+1)
5398         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5399         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5400         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5401         de_dt_num=(sumenep-sumene)/aincr
5402         write (2,*) " t+ sumene from enesc=",sumenep
5403         cost2tab(i+1)=costsave
5404         sint2tab(i+1)=sintsave
5405 C End of diagnostics section.
5406 #endif
5407 C
5408 C Compute the gradient of esc
5409 C
5410         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5411         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5412         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5413         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5414         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5415         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5416         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5417         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5418         pom1=(sumene3*sint2tab(i+1)+sumene1)
5419      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5420         pom2=(sumene4*cost2tab(i+1)+sumene2)
5421      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5422         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5423         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5424      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5425      &  +x(40)*yy*zz
5426         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5427         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5428      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5429      &  +x(60)*yy*zz
5430         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5431      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5432      &        +(pom1+pom2)*pom_dx
5433 #ifdef DEBUG
5434         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5435 #endif
5436 C
5437         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5438         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5439      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5440      &  +x(40)*xx*zz
5441         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5442         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5443      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5444      &  +x(59)*zz**2 +x(60)*xx*zz
5445         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5446      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5447      &        +(pom1-pom2)*pom_dy
5448 #ifdef DEBUG
5449         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5450 #endif
5451 C
5452         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5453      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5454      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5455      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5456      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5457      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5458      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5459      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5460 #ifdef DEBUG
5461         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5462 #endif
5463 C
5464         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5465      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5466      &  +pom1*pom_dt1+pom2*pom_dt2
5467 #ifdef DEBUG
5468         write(2,*), "de_dt = ", de_dt,de_dt_num
5469 #endif
5470 c
5471 C
5472        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5473        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5474        cosfac2xx=cosfac2*xx
5475        sinfac2yy=sinfac2*yy
5476        do k = 1,3
5477          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5478      &      vbld_inv(i+1)
5479          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5480      &      vbld_inv(i)
5481          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5482          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5483 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5484 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5485 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5486 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5487          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5488          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5489          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5490          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5491          dZZ_Ci1(k)=0.0d0
5492          dZZ_Ci(k)=0.0d0
5493          do j=1,3
5494            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5495            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5496          enddo
5497
5498          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5499          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5500          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5501 c
5502          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5503          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5504        enddo
5505
5506        do k=1,3
5507          dXX_Ctab(k,i)=dXX_Ci(k)
5508          dXX_C1tab(k,i)=dXX_Ci1(k)
5509          dYY_Ctab(k,i)=dYY_Ci(k)
5510          dYY_C1tab(k,i)=dYY_Ci1(k)
5511          dZZ_Ctab(k,i)=dZZ_Ci(k)
5512          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5513          dXX_XYZtab(k,i)=dXX_XYZ(k)
5514          dYY_XYZtab(k,i)=dYY_XYZ(k)
5515          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5516        enddo
5517
5518        do k = 1,3
5519 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5520 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5521 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5522 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5523 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5524 c     &    dt_dci(k)
5525 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5526 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5527          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5528      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5529          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5530      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5531          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5532      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5533        enddo
5534 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5535 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5536
5537 C to check gradient call subroutine check_grad
5538
5539     1 continue
5540       enddo
5541       return
5542       end
5543 c------------------------------------------------------------------------------
5544       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5545       implicit none
5546       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5547      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5548       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5549      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5550      &   + x(10)*yy*zz
5551       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5552      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5553      & + x(20)*yy*zz
5554       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5555      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5556      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5557      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5558      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5559      &  +x(40)*xx*yy*zz
5560       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5561      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5562      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5563      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5564      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5565      &  +x(60)*xx*yy*zz
5566       dsc_i   = 0.743d0+x(61)
5567       dp2_i   = 1.9d0+x(62)
5568       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5569      &          *(xx*cost2+yy*sint2))
5570       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5571      &          *(xx*cost2-yy*sint2))
5572       s1=(1+x(63))/(0.1d0 + dscp1)
5573       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5574       s2=(1+x(65))/(0.1d0 + dscp2)
5575       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5576       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5577      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5578       enesc=sumene
5579       return
5580       end
5581 #endif
5582 c------------------------------------------------------------------------------
5583       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5584 C
5585 C This procedure calculates two-body contact function g(rij) and its derivative:
5586 C
5587 C           eps0ij                                     !       x < -1
5588 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5589 C            0                                         !       x > 1
5590 C
5591 C where x=(rij-r0ij)/delta
5592 C
5593 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5594 C
5595       implicit none
5596       double precision rij,r0ij,eps0ij,fcont,fprimcont
5597       double precision x,x2,x4,delta
5598 c     delta=0.02D0*r0ij
5599 c      delta=0.2D0*r0ij
5600       x=(rij-r0ij)/delta
5601       if (x.lt.-1.0D0) then
5602         fcont=eps0ij
5603         fprimcont=0.0D0
5604       else if (x.le.1.0D0) then
5605         x2=x*x
5606         x4=x2*x2
5607         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5608         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5609       else
5610         fcont=0.0D0
5611         fprimcont=0.0D0
5612       endif
5613       return
5614       end
5615 c------------------------------------------------------------------------------
5616       subroutine splinthet(theti,delta,ss,ssder)
5617       implicit real*8 (a-h,o-z)
5618       include 'DIMENSIONS'
5619       include 'COMMON.VAR'
5620       include 'COMMON.GEO'
5621       thetup=pi-delta
5622       thetlow=delta
5623       if (theti.gt.pipol) then
5624         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5625       else
5626         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5627         ssder=-ssder
5628       endif
5629       return
5630       end
5631 c------------------------------------------------------------------------------
5632       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5633       implicit none
5634       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5635       double precision ksi,ksi2,ksi3,a1,a2,a3
5636       a1=fprim0*delta/(f1-f0)
5637       a2=3.0d0-2.0d0*a1
5638       a3=a1-2.0d0
5639       ksi=(x-x0)/delta
5640       ksi2=ksi*ksi
5641       ksi3=ksi2*ksi
5642       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5643       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5644       return
5645       end
5646 c------------------------------------------------------------------------------
5647       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5648       implicit none
5649       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5650       double precision ksi,ksi2,ksi3,a1,a2,a3
5651       ksi=(x-x0)/delta
5652       ksi2=ksi*ksi
5653       ksi3=ksi2*ksi
5654       a1=fprim0x*delta
5655       a2=3*(f1x-f0x)-2*fprim0x*delta
5656       a3=fprim0x*delta-2*(f1x-f0x)
5657       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5658       return
5659       end
5660 C-----------------------------------------------------------------------------
5661 #ifdef CRYST_TOR
5662 C-----------------------------------------------------------------------------
5663       subroutine etor(etors,edihcnstr)
5664       implicit real*8 (a-h,o-z)
5665       include 'DIMENSIONS'
5666       include 'COMMON.VAR'
5667       include 'COMMON.GEO'
5668       include 'COMMON.LOCAL'
5669       include 'COMMON.TORSION'
5670       include 'COMMON.INTERACT'
5671       include 'COMMON.DERIV'
5672       include 'COMMON.CHAIN'
5673       include 'COMMON.NAMES'
5674       include 'COMMON.IOUNITS'
5675       include 'COMMON.FFIELD'
5676       include 'COMMON.TORCNSTR'
5677       include 'COMMON.CONTROL'
5678       logical lprn
5679 C Set lprn=.true. for debugging
5680       lprn=.false.
5681 c      lprn=.true.
5682       etors=0.0D0
5683       do i=iphi_start,iphi_end
5684       etors_ii=0.0D0
5685         itori=itortyp(itype(i-2))
5686         itori1=itortyp(itype(i-1))
5687         phii=phi(i)
5688         gloci=0.0D0
5689 C Proline-Proline pair is a special case...
5690         if (itori.eq.3 .and. itori1.eq.3) then
5691           if (phii.gt.-dwapi3) then
5692             cosphi=dcos(3*phii)
5693             fac=1.0D0/(1.0D0-cosphi)
5694             etorsi=v1(1,3,3)*fac
5695             etorsi=etorsi+etorsi
5696             etors=etors+etorsi-v1(1,3,3)
5697             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5698             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5699           endif
5700           do j=1,3
5701             v1ij=v1(j+1,itori,itori1)
5702             v2ij=v2(j+1,itori,itori1)
5703             cosphi=dcos(j*phii)
5704             sinphi=dsin(j*phii)
5705             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5706             if (energy_dec) etors_ii=etors_ii+
5707      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5708             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5709           enddo
5710         else
5711           do j=1,nterm_old
5712             v1ij=v1(j,itori,itori1)
5713             v2ij=v2(j,itori,itori1)
5714             cosphi=dcos(j*phii)
5715             sinphi=dsin(j*phii)
5716             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5717             if (energy_dec) etors_ii=etors_ii+
5718      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5719             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5720           enddo
5721         endif
5722         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5723      &        'etor',i,etors_ii
5724         if (lprn)
5725      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5726      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5727      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5728         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5729         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5730       enddo
5731 ! 6/20/98 - dihedral angle constraints
5732       edihcnstr=0.0d0
5733       do i=1,ndih_constr
5734         itori=idih_constr(i)
5735         phii=phi(itori)
5736         difi=phii-phi0(i)
5737         if (difi.gt.drange(i)) then
5738           difi=difi-drange(i)
5739           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5740           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5741         else if (difi.lt.-drange(i)) then
5742           difi=difi+drange(i)
5743           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5744           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5745         endif
5746 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5747 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5748       enddo
5749 !      write (iout,*) 'edihcnstr',edihcnstr
5750       return
5751       end
5752 c------------------------------------------------------------------------------
5753       subroutine etor_d(etors_d)
5754       etors_d=0.0d0
5755       return
5756       end
5757 c----------------------------------------------------------------------------
5758 #else
5759       subroutine etor(etors,edihcnstr)
5760       implicit real*8 (a-h,o-z)
5761       include 'DIMENSIONS'
5762       include 'COMMON.VAR'
5763       include 'COMMON.GEO'
5764       include 'COMMON.LOCAL'
5765       include 'COMMON.TORSION'
5766       include 'COMMON.INTERACT'
5767       include 'COMMON.DERIV'
5768       include 'COMMON.CHAIN'
5769       include 'COMMON.NAMES'
5770       include 'COMMON.IOUNITS'
5771       include 'COMMON.FFIELD'
5772       include 'COMMON.TORCNSTR'
5773       include 'COMMON.CONTROL'
5774       logical lprn
5775 C Set lprn=.true. for debugging
5776       lprn=.false.
5777 c     lprn=.true.
5778       etors=0.0D0
5779       do i=iphi_start,iphi_end
5780       etors_ii=0.0D0
5781         itori=itortyp(itype(i-2))
5782         itori1=itortyp(itype(i-1))
5783         phii=phi(i)
5784         gloci=0.0D0
5785 C Regular cosine and sine terms
5786         do j=1,nterm(itori,itori1)
5787           v1ij=v1(j,itori,itori1)
5788           v2ij=v2(j,itori,itori1)
5789           cosphi=dcos(j*phii)
5790           sinphi=dsin(j*phii)
5791           etors=etors+v1ij*cosphi+v2ij*sinphi
5792           if (energy_dec) etors_ii=etors_ii+
5793      &                v1ij*cosphi+v2ij*sinphi
5794           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5795         enddo
5796 C Lorentz terms
5797 C                         v1
5798 C  E = SUM ----------------------------------- - v1
5799 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5800 C
5801         cosphi=dcos(0.5d0*phii)
5802         sinphi=dsin(0.5d0*phii)
5803         do j=1,nlor(itori,itori1)
5804           vl1ij=vlor1(j,itori,itori1)
5805           vl2ij=vlor2(j,itori,itori1)
5806           vl3ij=vlor3(j,itori,itori1)
5807           pom=vl2ij*cosphi+vl3ij*sinphi
5808           pom1=1.0d0/(pom*pom+1.0d0)
5809           etors=etors+vl1ij*pom1
5810           if (energy_dec) etors_ii=etors_ii+
5811      &                vl1ij*pom1
5812           pom=-pom*pom1*pom1
5813           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5814         enddo
5815 C Subtract the constant term
5816         etors=etors-v0(itori,itori1)
5817           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5818      &         'etor',i,etors_ii-v0(itori,itori1)
5819         if (lprn)
5820      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5821      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5822      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5823         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5824 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5825       enddo
5826 ! 6/20/98 - dihedral angle constraints
5827       edihcnstr=0.0d0
5828 c      do i=1,ndih_constr
5829       do i=idihconstr_start,idihconstr_end
5830         itori=idih_constr(i)
5831         phii=phi(itori)
5832         difi=pinorm(phii-phi0(i))
5833         if (difi.gt.drange(i)) then
5834           difi=difi-drange(i)
5835           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5836           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5837         else if (difi.lt.-drange(i)) then
5838           difi=difi+drange(i)
5839           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5840           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5841         else
5842           difi=0.0
5843         endif
5844 c        write (iout,*) "gloci", gloc(i-3,icg)
5845 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5846 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5847 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5848       enddo
5849 cd       write (iout,*) 'edihcnstr',edihcnstr
5850       return
5851       end
5852 c----------------------------------------------------------------------------
5853       subroutine etor_d(etors_d)
5854 C 6/23/01 Compute double torsional energy
5855       implicit real*8 (a-h,o-z)
5856       include 'DIMENSIONS'
5857       include 'COMMON.VAR'
5858       include 'COMMON.GEO'
5859       include 'COMMON.LOCAL'
5860       include 'COMMON.TORSION'
5861       include 'COMMON.INTERACT'
5862       include 'COMMON.DERIV'
5863       include 'COMMON.CHAIN'
5864       include 'COMMON.NAMES'
5865       include 'COMMON.IOUNITS'
5866       include 'COMMON.FFIELD'
5867       include 'COMMON.TORCNSTR'
5868       logical lprn
5869 C Set lprn=.true. for debugging
5870       lprn=.false.
5871 c     lprn=.true.
5872       etors_d=0.0D0
5873       do i=iphid_start,iphid_end
5874         itori=itortyp(itype(i-2))
5875         itori1=itortyp(itype(i-1))
5876         itori2=itortyp(itype(i))
5877         phii=phi(i)
5878         phii1=phi(i+1)
5879         gloci1=0.0D0
5880         gloci2=0.0D0
5881         do j=1,ntermd_1(itori,itori1,itori2)
5882           v1cij=v1c(1,j,itori,itori1,itori2)
5883           v1sij=v1s(1,j,itori,itori1,itori2)
5884           v2cij=v1c(2,j,itori,itori1,itori2)
5885           v2sij=v1s(2,j,itori,itori1,itori2)
5886           cosphi1=dcos(j*phii)
5887           sinphi1=dsin(j*phii)
5888           cosphi2=dcos(j*phii1)
5889           sinphi2=dsin(j*phii1)
5890           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5891      &     v2cij*cosphi2+v2sij*sinphi2
5892           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5893           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5894         enddo
5895         do k=2,ntermd_2(itori,itori1,itori2)
5896           do l=1,k-1
5897             v1cdij = v2c(k,l,itori,itori1,itori2)
5898             v2cdij = v2c(l,k,itori,itori1,itori2)
5899             v1sdij = v2s(k,l,itori,itori1,itori2)
5900             v2sdij = v2s(l,k,itori,itori1,itori2)
5901             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5902             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5903             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5904             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5905             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5906      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5907             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5908      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5909             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5910      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5911           enddo
5912         enddo
5913         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5914         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5915 c        write (iout,*) "gloci", gloc(i-3,icg)
5916       enddo
5917       return
5918       end
5919 #endif
5920 c------------------------------------------------------------------------------
5921       subroutine eback_sc_corr(esccor)
5922 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5923 c        conformational states; temporarily implemented as differences
5924 c        between UNRES torsional potentials (dependent on three types of
5925 c        residues) and the torsional potentials dependent on all 20 types
5926 c        of residues computed from AM1  energy surfaces of terminally-blocked
5927 c        amino-acid residues.
5928       implicit real*8 (a-h,o-z)
5929       include 'DIMENSIONS'
5930       include 'COMMON.VAR'
5931       include 'COMMON.GEO'
5932       include 'COMMON.LOCAL'
5933       include 'COMMON.TORSION'
5934       include 'COMMON.SCCOR'
5935       include 'COMMON.INTERACT'
5936       include 'COMMON.DERIV'
5937       include 'COMMON.CHAIN'
5938       include 'COMMON.NAMES'
5939       include 'COMMON.IOUNITS'
5940       include 'COMMON.FFIELD'
5941       include 'COMMON.CONTROL'
5942       logical lprn
5943 C Set lprn=.true. for debugging
5944       lprn=.false.
5945 c      lprn=.true.
5946 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5947       esccor=0.0D0
5948       do i=itau_start,itau_end
5949         esccor_ii=0.0D0
5950         isccori=isccortyp(itype(i-2))
5951         isccori1=isccortyp(itype(i-1))
5952         phii=phi(i)
5953 cccc  Added 9 May 2012
5954 cc Tauangle is torsional engle depending on the value of first digit
5955 c(see comment below)
5956 cc Omicron is flat angle depending on the value of first digit
5957 c(see comment below)
5958
5959
5960         do intertyp=1,3 !intertyp
5961 cc Added 09 May 2012 (Adasko)
5962 cc  Intertyp means interaction type of backbone mainchain correlation:
5963 c   1 = SC...Ca...Ca...Ca
5964 c   2 = Ca...Ca...Ca...SC
5965 c   3 = SC...Ca...Ca...SCi
5966         gloci=0.0D0
5967         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5968      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5969      &      (itype(i-1).eq.21)))
5970      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5971      &     .or.(itype(i-2).eq.21)))
5972      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5973      &      (itype(i-1).eq.21)))) cycle
5974         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
5975         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
5976      & cycle
5977         do j=1,nterm_sccor(isccori,isccori1)
5978           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5979           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5980           cosphi=dcos(j*tauangle(intertyp,i))
5981           sinphi=dsin(j*tauangle(intertyp,i))
5982           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5983           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5984         enddo
5985         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5986 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
5987 c     &gloc_sc(intertyp,i-3,icg)
5988         if (lprn)
5989      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5990      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5991      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5992      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5993         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5994        enddo !intertyp
5995       enddo
5996 c        do i=1,nres
5997 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5998 c        enddo
5999       return
6000       end
6001 c----------------------------------------------------------------------------
6002       subroutine multibody(ecorr)
6003 C This subroutine calculates multi-body contributions to energy following
6004 C the idea of Skolnick et al. If side chains I and J make a contact and
6005 C at the same time side chains I+1 and J+1 make a contact, an extra
6006 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6007       implicit real*8 (a-h,o-z)
6008       include 'DIMENSIONS'
6009       include 'COMMON.IOUNITS'
6010       include 'COMMON.DERIV'
6011       include 'COMMON.INTERACT'
6012       include 'COMMON.CONTACTS'
6013       double precision gx(3),gx1(3)
6014       logical lprn
6015
6016 C Set lprn=.true. for debugging
6017       lprn=.false.
6018
6019       if (lprn) then
6020         write (iout,'(a)') 'Contact function values:'
6021         do i=nnt,nct-2
6022           write (iout,'(i2,20(1x,i2,f10.5))')
6023      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6024         enddo
6025       endif
6026       ecorr=0.0D0
6027       do i=nnt,nct
6028         do j=1,3
6029           gradcorr(j,i)=0.0D0
6030           gradxorr(j,i)=0.0D0
6031         enddo
6032       enddo
6033       do i=nnt,nct-2
6034
6035         DO ISHIFT = 3,4
6036
6037         i1=i+ishift
6038         num_conti=num_cont(i)
6039         num_conti1=num_cont(i1)
6040         do jj=1,num_conti
6041           j=jcont(jj,i)
6042           do kk=1,num_conti1
6043             j1=jcont(kk,i1)
6044             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6045 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6046 cd   &                   ' ishift=',ishift
6047 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6048 C The system gains extra energy.
6049               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6050             endif   ! j1==j+-ishift
6051           enddo     ! kk
6052         enddo       ! jj
6053
6054         ENDDO ! ISHIFT
6055
6056       enddo         ! i
6057       return
6058       end
6059 c------------------------------------------------------------------------------
6060       double precision function esccorr(i,j,k,l,jj,kk)
6061       implicit real*8 (a-h,o-z)
6062       include 'DIMENSIONS'
6063       include 'COMMON.IOUNITS'
6064       include 'COMMON.DERIV'
6065       include 'COMMON.INTERACT'
6066       include 'COMMON.CONTACTS'
6067       double precision gx(3),gx1(3)
6068       logical lprn
6069       lprn=.false.
6070       eij=facont(jj,i)
6071       ekl=facont(kk,k)
6072 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6073 C Calculate the multi-body contribution to energy.
6074 C Calculate multi-body contributions to the gradient.
6075 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6076 cd   & k,l,(gacont(m,kk,k),m=1,3)
6077       do m=1,3
6078         gx(m) =ekl*gacont(m,jj,i)
6079         gx1(m)=eij*gacont(m,kk,k)
6080         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6081         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6082         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6083         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6084       enddo
6085       do m=i,j-1
6086         do ll=1,3
6087           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6088         enddo
6089       enddo
6090       do m=k,l-1
6091         do ll=1,3
6092           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6093         enddo
6094       enddo
6095       esccorr=-eij*ekl
6096       return
6097       end
6098 c------------------------------------------------------------------------------
6099       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6100 C This subroutine calculates multi-body contributions to hydrogen-bonding
6101       implicit real*8 (a-h,o-z)
6102       include 'DIMENSIONS'
6103       include 'COMMON.IOUNITS'
6104 #ifdef MPI
6105       include "mpif.h"
6106       parameter (max_cont=maxconts)
6107       parameter (max_dim=26)
6108       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6109       double precision zapas(max_dim,maxconts,max_fg_procs),
6110      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6111       common /przechowalnia/ zapas
6112       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6113      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6114 #endif
6115       include 'COMMON.SETUP'
6116       include 'COMMON.FFIELD'
6117       include 'COMMON.DERIV'
6118       include 'COMMON.INTERACT'
6119       include 'COMMON.CONTACTS'
6120       include 'COMMON.CONTROL'
6121       include 'COMMON.LOCAL'
6122       double precision gx(3),gx1(3),time00
6123       logical lprn,ldone
6124
6125 C Set lprn=.true. for debugging
6126       lprn=.false.
6127 #ifdef MPI
6128       n_corr=0
6129       n_corr1=0
6130       if (nfgtasks.le.1) goto 30
6131       if (lprn) then
6132         write (iout,'(a)') 'Contact function values before RECEIVE:'
6133         do i=nnt,nct-2
6134           write (iout,'(2i3,50(1x,i2,f5.2))')
6135      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6136      &    j=1,num_cont_hb(i))
6137         enddo
6138       endif
6139       call flush(iout)
6140       do i=1,ntask_cont_from
6141         ncont_recv(i)=0
6142       enddo
6143       do i=1,ntask_cont_to
6144         ncont_sent(i)=0
6145       enddo
6146 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6147 c     & ntask_cont_to
6148 C Make the list of contacts to send to send to other procesors
6149 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6150 c      call flush(iout)
6151       do i=iturn3_start,iturn3_end
6152 c        write (iout,*) "make contact list turn3",i," num_cont",
6153 c     &    num_cont_hb(i)
6154         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6155       enddo
6156       do i=iturn4_start,iturn4_end
6157 c        write (iout,*) "make contact list turn4",i," num_cont",
6158 c     &   num_cont_hb(i)
6159         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6160       enddo
6161       do ii=1,nat_sent
6162         i=iat_sent(ii)
6163 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6164 c     &    num_cont_hb(i)
6165         do j=1,num_cont_hb(i)
6166         do k=1,4
6167           jjc=jcont_hb(j,i)
6168           iproc=iint_sent_local(k,jjc,ii)
6169 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6170           if (iproc.gt.0) then
6171             ncont_sent(iproc)=ncont_sent(iproc)+1
6172             nn=ncont_sent(iproc)
6173             zapas(1,nn,iproc)=i
6174             zapas(2,nn,iproc)=jjc
6175             zapas(3,nn,iproc)=facont_hb(j,i)
6176             zapas(4,nn,iproc)=ees0p(j,i)
6177             zapas(5,nn,iproc)=ees0m(j,i)
6178             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6179             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6180             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6181             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6182             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6183             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6184             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6185             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6186             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6187             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6188             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6189             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6190             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6191             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6192             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6193             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6194             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6195             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6196             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6197             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6198             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6199           endif
6200         enddo
6201         enddo
6202       enddo
6203       if (lprn) then
6204       write (iout,*)
6205      &  "Numbers of contacts to be sent to other processors",
6206      &  (ncont_sent(i),i=1,ntask_cont_to)
6207       write (iout,*) "Contacts sent"
6208       do ii=1,ntask_cont_to
6209         nn=ncont_sent(ii)
6210         iproc=itask_cont_to(ii)
6211         write (iout,*) nn," contacts to processor",iproc,
6212      &   " of CONT_TO_COMM group"
6213         do i=1,nn
6214           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6215         enddo
6216       enddo
6217       call flush(iout)
6218       endif
6219       CorrelType=477
6220       CorrelID=fg_rank+1
6221       CorrelType1=478
6222       CorrelID1=nfgtasks+fg_rank+1
6223       ireq=0
6224 C Receive the numbers of needed contacts from other processors
6225       do ii=1,ntask_cont_from
6226         iproc=itask_cont_from(ii)
6227         ireq=ireq+1
6228         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6229      &    FG_COMM,req(ireq),IERR)
6230       enddo
6231 c      write (iout,*) "IRECV ended"
6232 c      call flush(iout)
6233 C Send the number of contacts needed by other processors
6234       do ii=1,ntask_cont_to
6235         iproc=itask_cont_to(ii)
6236         ireq=ireq+1
6237         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6238      &    FG_COMM,req(ireq),IERR)
6239       enddo
6240 c      write (iout,*) "ISEND ended"
6241 c      write (iout,*) "number of requests (nn)",ireq
6242       call flush(iout)
6243       if (ireq.gt.0)
6244      &  call MPI_Waitall(ireq,req,status_array,ierr)
6245 c      write (iout,*)
6246 c     &  "Numbers of contacts to be received from other processors",
6247 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6248 c      call flush(iout)
6249 C Receive contacts
6250       ireq=0
6251       do ii=1,ntask_cont_from
6252         iproc=itask_cont_from(ii)
6253         nn=ncont_recv(ii)
6254 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6255 c     &   " of CONT_TO_COMM group"
6256         call flush(iout)
6257         if (nn.gt.0) then
6258           ireq=ireq+1
6259           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6260      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6261 c          write (iout,*) "ireq,req",ireq,req(ireq)
6262         endif
6263       enddo
6264 C Send the contacts to processors that need them
6265       do ii=1,ntask_cont_to
6266         iproc=itask_cont_to(ii)
6267         nn=ncont_sent(ii)
6268 c        write (iout,*) nn," contacts to processor",iproc,
6269 c     &   " of CONT_TO_COMM group"
6270         if (nn.gt.0) then
6271           ireq=ireq+1
6272           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6273      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6274 c          write (iout,*) "ireq,req",ireq,req(ireq)
6275 c          do i=1,nn
6276 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6277 c          enddo
6278         endif
6279       enddo
6280 c      write (iout,*) "number of requests (contacts)",ireq
6281 c      write (iout,*) "req",(req(i),i=1,4)
6282 c      call flush(iout)
6283       if (ireq.gt.0)
6284      & call MPI_Waitall(ireq,req,status_array,ierr)
6285       do iii=1,ntask_cont_from
6286         iproc=itask_cont_from(iii)
6287         nn=ncont_recv(iii)
6288         if (lprn) then
6289         write (iout,*) "Received",nn," contacts from processor",iproc,
6290      &   " of CONT_FROM_COMM group"
6291         call flush(iout)
6292         do i=1,nn
6293           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6294         enddo
6295         call flush(iout)
6296         endif
6297         do i=1,nn
6298           ii=zapas_recv(1,i,iii)
6299 c Flag the received contacts to prevent double-counting
6300           jj=-zapas_recv(2,i,iii)
6301 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6302 c          call flush(iout)
6303           nnn=num_cont_hb(ii)+1
6304           num_cont_hb(ii)=nnn
6305           jcont_hb(nnn,ii)=jj
6306           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6307           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6308           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6309           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6310           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6311           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6312           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6313           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6314           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6315           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6316           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6317           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6318           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6319           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6320           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6321           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6322           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6323           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6324           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6325           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6326           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6327           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6328           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6329           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6330         enddo
6331       enddo
6332       call flush(iout)
6333       if (lprn) then
6334         write (iout,'(a)') 'Contact function values after receive:'
6335         do i=nnt,nct-2
6336           write (iout,'(2i3,50(1x,i3,f5.2))')
6337      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6338      &    j=1,num_cont_hb(i))
6339         enddo
6340         call flush(iout)
6341       endif
6342    30 continue
6343 #endif
6344       if (lprn) then
6345         write (iout,'(a)') 'Contact function values:'
6346         do i=nnt,nct-2
6347           write (iout,'(2i3,50(1x,i3,f5.2))')
6348      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6349      &    j=1,num_cont_hb(i))
6350         enddo
6351       endif
6352       ecorr=0.0D0
6353 C Remove the loop below after debugging !!!
6354       do i=nnt,nct
6355         do j=1,3
6356           gradcorr(j,i)=0.0D0
6357           gradxorr(j,i)=0.0D0
6358         enddo
6359       enddo
6360 C Calculate the local-electrostatic correlation terms
6361       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6362         i1=i+1
6363         num_conti=num_cont_hb(i)
6364         num_conti1=num_cont_hb(i+1)
6365         do jj=1,num_conti
6366           j=jcont_hb(jj,i)
6367           jp=iabs(j)
6368           do kk=1,num_conti1
6369             j1=jcont_hb(kk,i1)
6370             jp1=iabs(j1)
6371 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6372 c     &         ' jj=',jj,' kk=',kk
6373             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6374      &          .or. j.lt.0 .and. j1.gt.0) .and.
6375      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6376 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6377 C The system gains extra energy.
6378               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6379               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6380      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6381               n_corr=n_corr+1
6382             else if (j1.eq.j) then
6383 C Contacts I-J and I-(J+1) occur simultaneously.
6384 C The system loses extra energy.
6385 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6386             endif
6387           enddo ! kk
6388           do kk=1,num_conti
6389             j1=jcont_hb(kk,i)
6390 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6391 c    &         ' jj=',jj,' kk=',kk
6392             if (j1.eq.j+1) then
6393 C Contacts I-J and (I+1)-J occur simultaneously.
6394 C The system loses extra energy.
6395 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6396             endif ! j1==j+1
6397           enddo ! kk
6398         enddo ! jj
6399       enddo ! i
6400       return
6401       end
6402 c------------------------------------------------------------------------------
6403       subroutine add_hb_contact(ii,jj,itask)
6404       implicit real*8 (a-h,o-z)
6405       include "DIMENSIONS"
6406       include "COMMON.IOUNITS"
6407       integer max_cont
6408       integer max_dim
6409       parameter (max_cont=maxconts)
6410       parameter (max_dim=26)
6411       include "COMMON.CONTACTS"
6412       double precision zapas(max_dim,maxconts,max_fg_procs),
6413      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6414       common /przechowalnia/ zapas
6415       integer i,j,ii,jj,iproc,itask(4),nn
6416 c      write (iout,*) "itask",itask
6417       do i=1,2
6418         iproc=itask(i)
6419         if (iproc.gt.0) then
6420           do j=1,num_cont_hb(ii)
6421             jjc=jcont_hb(j,ii)
6422 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6423             if (jjc.eq.jj) then
6424               ncont_sent(iproc)=ncont_sent(iproc)+1
6425               nn=ncont_sent(iproc)
6426               zapas(1,nn,iproc)=ii
6427               zapas(2,nn,iproc)=jjc
6428               zapas(3,nn,iproc)=facont_hb(j,ii)
6429               zapas(4,nn,iproc)=ees0p(j,ii)
6430               zapas(5,nn,iproc)=ees0m(j,ii)
6431               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6432               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6433               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6434               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6435               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6436               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6437               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6438               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6439               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6440               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6441               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6442               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6443               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6444               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6445               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6446               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6447               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6448               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6449               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6450               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6451               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6452               exit
6453             endif
6454           enddo
6455         endif
6456       enddo
6457       return
6458       end
6459 c------------------------------------------------------------------------------
6460       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6461      &  n_corr1)
6462 C This subroutine calculates multi-body contributions to hydrogen-bonding
6463       implicit real*8 (a-h,o-z)
6464       include 'DIMENSIONS'
6465       include 'COMMON.IOUNITS'
6466 #ifdef MPI
6467       include "mpif.h"
6468       parameter (max_cont=maxconts)
6469       parameter (max_dim=70)
6470       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6471       double precision zapas(max_dim,maxconts,max_fg_procs),
6472      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6473       common /przechowalnia/ zapas
6474       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6475      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6476 #endif
6477       include 'COMMON.SETUP'
6478       include 'COMMON.FFIELD'
6479       include 'COMMON.DERIV'
6480       include 'COMMON.LOCAL'
6481       include 'COMMON.INTERACT'
6482       include 'COMMON.CONTACTS'
6483       include 'COMMON.CHAIN'
6484       include 'COMMON.CONTROL'
6485       double precision gx(3),gx1(3)
6486       integer num_cont_hb_old(maxres)
6487       logical lprn,ldone
6488       double precision eello4,eello5,eelo6,eello_turn6
6489       external eello4,eello5,eello6,eello_turn6
6490 C Set lprn=.true. for debugging
6491       lprn=.false.
6492       eturn6=0.0d0
6493 #ifdef MPI
6494       do i=1,nres
6495         num_cont_hb_old(i)=num_cont_hb(i)
6496       enddo
6497       n_corr=0
6498       n_corr1=0
6499       if (nfgtasks.le.1) goto 30
6500       if (lprn) then
6501         write (iout,'(a)') 'Contact function values before RECEIVE:'
6502         do i=nnt,nct-2
6503           write (iout,'(2i3,50(1x,i2,f5.2))')
6504      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6505      &    j=1,num_cont_hb(i))
6506         enddo
6507       endif
6508       call flush(iout)
6509       do i=1,ntask_cont_from
6510         ncont_recv(i)=0
6511       enddo
6512       do i=1,ntask_cont_to
6513         ncont_sent(i)=0
6514       enddo
6515 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6516 c     & ntask_cont_to
6517 C Make the list of contacts to send to send to other procesors
6518       do i=iturn3_start,iturn3_end
6519 c        write (iout,*) "make contact list turn3",i," num_cont",
6520 c     &    num_cont_hb(i)
6521         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6522       enddo
6523       do i=iturn4_start,iturn4_end
6524 c        write (iout,*) "make contact list turn4",i," num_cont",
6525 c     &   num_cont_hb(i)
6526         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6527       enddo
6528       do ii=1,nat_sent
6529         i=iat_sent(ii)
6530 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6531 c     &    num_cont_hb(i)
6532         do j=1,num_cont_hb(i)
6533         do k=1,4
6534           jjc=jcont_hb(j,i)
6535           iproc=iint_sent_local(k,jjc,ii)
6536 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6537           if (iproc.ne.0) then
6538             ncont_sent(iproc)=ncont_sent(iproc)+1
6539             nn=ncont_sent(iproc)
6540             zapas(1,nn,iproc)=i
6541             zapas(2,nn,iproc)=jjc
6542             zapas(3,nn,iproc)=d_cont(j,i)
6543             ind=3
6544             do kk=1,3
6545               ind=ind+1
6546               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6547             enddo
6548             do kk=1,2
6549               do ll=1,2
6550                 ind=ind+1
6551                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6552               enddo
6553             enddo
6554             do jj=1,5
6555               do kk=1,3
6556                 do ll=1,2
6557                   do mm=1,2
6558                     ind=ind+1
6559                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6560                   enddo
6561                 enddo
6562               enddo
6563             enddo
6564           endif
6565         enddo
6566         enddo
6567       enddo
6568       if (lprn) then
6569       write (iout,*)
6570      &  "Numbers of contacts to be sent to other processors",
6571      &  (ncont_sent(i),i=1,ntask_cont_to)
6572       write (iout,*) "Contacts sent"
6573       do ii=1,ntask_cont_to
6574         nn=ncont_sent(ii)
6575         iproc=itask_cont_to(ii)
6576         write (iout,*) nn," contacts to processor",iproc,
6577      &   " of CONT_TO_COMM group"
6578         do i=1,nn
6579           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6580         enddo
6581       enddo
6582       call flush(iout)
6583       endif
6584       CorrelType=477
6585       CorrelID=fg_rank+1
6586       CorrelType1=478
6587       CorrelID1=nfgtasks+fg_rank+1
6588       ireq=0
6589 C Receive the numbers of needed contacts from other processors
6590       do ii=1,ntask_cont_from
6591         iproc=itask_cont_from(ii)
6592         ireq=ireq+1
6593         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6594      &    FG_COMM,req(ireq),IERR)
6595       enddo
6596 c      write (iout,*) "IRECV ended"
6597 c      call flush(iout)
6598 C Send the number of contacts needed by other processors
6599       do ii=1,ntask_cont_to
6600         iproc=itask_cont_to(ii)
6601         ireq=ireq+1
6602         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6603      &    FG_COMM,req(ireq),IERR)
6604       enddo
6605 c      write (iout,*) "ISEND ended"
6606 c      write (iout,*) "number of requests (nn)",ireq
6607       call flush(iout)
6608       if (ireq.gt.0)
6609      &  call MPI_Waitall(ireq,req,status_array,ierr)
6610 c      write (iout,*)
6611 c     &  "Numbers of contacts to be received from other processors",
6612 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6613 c      call flush(iout)
6614 C Receive contacts
6615       ireq=0
6616       do ii=1,ntask_cont_from
6617         iproc=itask_cont_from(ii)
6618         nn=ncont_recv(ii)
6619 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6620 c     &   " of CONT_TO_COMM group"
6621         call flush(iout)
6622         if (nn.gt.0) then
6623           ireq=ireq+1
6624           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6625      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6626 c          write (iout,*) "ireq,req",ireq,req(ireq)
6627         endif
6628       enddo
6629 C Send the contacts to processors that need them
6630       do ii=1,ntask_cont_to
6631         iproc=itask_cont_to(ii)
6632         nn=ncont_sent(ii)
6633 c        write (iout,*) nn," contacts to processor",iproc,
6634 c     &   " of CONT_TO_COMM group"
6635         if (nn.gt.0) then
6636           ireq=ireq+1
6637           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6638      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6639 c          write (iout,*) "ireq,req",ireq,req(ireq)
6640 c          do i=1,nn
6641 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6642 c          enddo
6643         endif
6644       enddo
6645 c      write (iout,*) "number of requests (contacts)",ireq
6646 c      write (iout,*) "req",(req(i),i=1,4)
6647 c      call flush(iout)
6648       if (ireq.gt.0)
6649      & call MPI_Waitall(ireq,req,status_array,ierr)
6650       do iii=1,ntask_cont_from
6651         iproc=itask_cont_from(iii)
6652         nn=ncont_recv(iii)
6653         if (lprn) then
6654         write (iout,*) "Received",nn," contacts from processor",iproc,
6655      &   " of CONT_FROM_COMM group"
6656         call flush(iout)
6657         do i=1,nn
6658           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6659         enddo
6660         call flush(iout)
6661         endif
6662         do i=1,nn
6663           ii=zapas_recv(1,i,iii)
6664 c Flag the received contacts to prevent double-counting
6665           jj=-zapas_recv(2,i,iii)
6666 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6667 c          call flush(iout)
6668           nnn=num_cont_hb(ii)+1
6669           num_cont_hb(ii)=nnn
6670           jcont_hb(nnn,ii)=jj
6671           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6672           ind=3
6673           do kk=1,3
6674             ind=ind+1
6675             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6676           enddo
6677           do kk=1,2
6678             do ll=1,2
6679               ind=ind+1
6680               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6681             enddo
6682           enddo
6683           do jj=1,5
6684             do kk=1,3
6685               do ll=1,2
6686                 do mm=1,2
6687                   ind=ind+1
6688                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6689                 enddo
6690               enddo
6691             enddo
6692           enddo
6693         enddo
6694       enddo
6695       call flush(iout)
6696       if (lprn) then
6697         write (iout,'(a)') 'Contact function values after receive:'
6698         do i=nnt,nct-2
6699           write (iout,'(2i3,50(1x,i3,5f6.3))')
6700      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6701      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6702         enddo
6703         call flush(iout)
6704       endif
6705    30 continue
6706 #endif
6707       if (lprn) then
6708         write (iout,'(a)') 'Contact function values:'
6709         do i=nnt,nct-2
6710           write (iout,'(2i3,50(1x,i2,5f6.3))')
6711      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6712      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6713         enddo
6714       endif
6715       ecorr=0.0D0
6716       ecorr5=0.0d0
6717       ecorr6=0.0d0
6718 C Remove the loop below after debugging !!!
6719       do i=nnt,nct
6720         do j=1,3
6721           gradcorr(j,i)=0.0D0
6722           gradxorr(j,i)=0.0D0
6723         enddo
6724       enddo
6725 C Calculate the dipole-dipole interaction energies
6726       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6727       do i=iatel_s,iatel_e+1
6728         num_conti=num_cont_hb(i)
6729         do jj=1,num_conti
6730           j=jcont_hb(jj,i)
6731 #ifdef MOMENT
6732           call dipole(i,j,jj)
6733 #endif
6734         enddo
6735       enddo
6736       endif
6737 C Calculate the local-electrostatic correlation terms
6738 c                write (iout,*) "gradcorr5 in eello5 before loop"
6739 c                do iii=1,nres
6740 c                  write (iout,'(i5,3f10.5)')
6741 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6742 c                enddo
6743       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6744 c        write (iout,*) "corr loop i",i
6745         i1=i+1
6746         num_conti=num_cont_hb(i)
6747         num_conti1=num_cont_hb(i+1)
6748         do jj=1,num_conti
6749           j=jcont_hb(jj,i)
6750           jp=iabs(j)
6751           do kk=1,num_conti1
6752             j1=jcont_hb(kk,i1)
6753             jp1=iabs(j1)
6754 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6755 c     &         ' jj=',jj,' kk=',kk
6756 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6757             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6758      &          .or. j.lt.0 .and. j1.gt.0) .and.
6759      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6760 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6761 C The system gains extra energy.
6762               n_corr=n_corr+1
6763               sqd1=dsqrt(d_cont(jj,i))
6764               sqd2=dsqrt(d_cont(kk,i1))
6765               sred_geom = sqd1*sqd2
6766               IF (sred_geom.lt.cutoff_corr) THEN
6767                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6768      &            ekont,fprimcont)
6769 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6770 cd     &         ' jj=',jj,' kk=',kk
6771                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6772                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6773                 do l=1,3
6774                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6775                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6776                 enddo
6777                 n_corr1=n_corr1+1
6778 cd               write (iout,*) 'sred_geom=',sred_geom,
6779 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6780 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6781 cd               write (iout,*) "g_contij",g_contij
6782 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6783 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6784                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6785                 if (wcorr4.gt.0.0d0)
6786      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6787                   if (energy_dec.and.wcorr4.gt.0.0d0)
6788      1                 write (iout,'(a6,4i5,0pf7.3)')
6789      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6790 c                write (iout,*) "gradcorr5 before eello5"
6791 c                do iii=1,nres
6792 c                  write (iout,'(i5,3f10.5)')
6793 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6794 c                enddo
6795                 if (wcorr5.gt.0.0d0)
6796      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6797 c                write (iout,*) "gradcorr5 after eello5"
6798 c                do iii=1,nres
6799 c                  write (iout,'(i5,3f10.5)')
6800 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6801 c                enddo
6802                   if (energy_dec.and.wcorr5.gt.0.0d0)
6803      1                 write (iout,'(a6,4i5,0pf7.3)')
6804      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6805 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6806 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6807                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6808      &               .or. wturn6.eq.0.0d0))then
6809 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6810                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6811                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6812      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6813 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6814 cd     &            'ecorr6=',ecorr6
6815 cd                write (iout,'(4e15.5)') sred_geom,
6816 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6817 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6818 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6819                 else if (wturn6.gt.0.0d0
6820      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6821 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6822                   eturn6=eturn6+eello_turn6(i,jj,kk)
6823                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6824      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6825 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6826                 endif
6827               ENDIF
6828 1111          continue
6829             endif
6830           enddo ! kk
6831         enddo ! jj
6832       enddo ! i
6833       do i=1,nres
6834         num_cont_hb(i)=num_cont_hb_old(i)
6835       enddo
6836 c                write (iout,*) "gradcorr5 in eello5"
6837 c                do iii=1,nres
6838 c                  write (iout,'(i5,3f10.5)')
6839 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6840 c                enddo
6841       return
6842       end
6843 c------------------------------------------------------------------------------
6844       subroutine add_hb_contact_eello(ii,jj,itask)
6845       implicit real*8 (a-h,o-z)
6846       include "DIMENSIONS"
6847       include "COMMON.IOUNITS"
6848       integer max_cont
6849       integer max_dim
6850       parameter (max_cont=maxconts)
6851       parameter (max_dim=70)
6852       include "COMMON.CONTACTS"
6853       double precision zapas(max_dim,maxconts,max_fg_procs),
6854      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6855       common /przechowalnia/ zapas
6856       integer i,j,ii,jj,iproc,itask(4),nn
6857 c      write (iout,*) "itask",itask
6858       do i=1,2
6859         iproc=itask(i)
6860         if (iproc.gt.0) then
6861           do j=1,num_cont_hb(ii)
6862             jjc=jcont_hb(j,ii)
6863 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6864             if (jjc.eq.jj) then
6865               ncont_sent(iproc)=ncont_sent(iproc)+1
6866               nn=ncont_sent(iproc)
6867               zapas(1,nn,iproc)=ii
6868               zapas(2,nn,iproc)=jjc
6869               zapas(3,nn,iproc)=d_cont(j,ii)
6870               ind=3
6871               do kk=1,3
6872                 ind=ind+1
6873                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6874               enddo
6875               do kk=1,2
6876                 do ll=1,2
6877                   ind=ind+1
6878                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6879                 enddo
6880               enddo
6881               do jj=1,5
6882                 do kk=1,3
6883                   do ll=1,2
6884                     do mm=1,2
6885                       ind=ind+1
6886                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6887                     enddo
6888                   enddo
6889                 enddo
6890               enddo
6891               exit
6892             endif
6893           enddo
6894         endif
6895       enddo
6896       return
6897       end
6898 c------------------------------------------------------------------------------
6899       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6900       implicit real*8 (a-h,o-z)
6901       include 'DIMENSIONS'
6902       include 'COMMON.IOUNITS'
6903       include 'COMMON.DERIV'
6904       include 'COMMON.INTERACT'
6905       include 'COMMON.CONTACTS'
6906       double precision gx(3),gx1(3)
6907       logical lprn
6908       lprn=.false.
6909       eij=facont_hb(jj,i)
6910       ekl=facont_hb(kk,k)
6911       ees0pij=ees0p(jj,i)
6912       ees0pkl=ees0p(kk,k)
6913       ees0mij=ees0m(jj,i)
6914       ees0mkl=ees0m(kk,k)
6915       ekont=eij*ekl
6916       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6917 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6918 C Following 4 lines for diagnostics.
6919 cd    ees0pkl=0.0D0
6920 cd    ees0pij=1.0D0
6921 cd    ees0mkl=0.0D0
6922 cd    ees0mij=1.0D0
6923 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6924 c     & 'Contacts ',i,j,
6925 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6926 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6927 c     & 'gradcorr_long'
6928 C Calculate the multi-body contribution to energy.
6929 c      ecorr=ecorr+ekont*ees
6930 C Calculate multi-body contributions to the gradient.
6931       coeffpees0pij=coeffp*ees0pij
6932       coeffmees0mij=coeffm*ees0mij
6933       coeffpees0pkl=coeffp*ees0pkl
6934       coeffmees0mkl=coeffm*ees0mkl
6935       do ll=1,3
6936 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6937         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6938      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6939      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6940         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6941      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6942      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6943 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6944         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6945      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6946      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6947         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6948      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6949      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6950         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6951      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6952      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6953         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6954         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6955         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6956      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6957      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6958         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6959         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6960 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6961       enddo
6962 c      write (iout,*)
6963 cgrad      do m=i+1,j-1
6964 cgrad        do ll=1,3
6965 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6966 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6967 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6968 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6969 cgrad        enddo
6970 cgrad      enddo
6971 cgrad      do m=k+1,l-1
6972 cgrad        do ll=1,3
6973 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6974 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6975 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6976 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6977 cgrad        enddo
6978 cgrad      enddo
6979 c      write (iout,*) "ehbcorr",ekont*ees
6980       ehbcorr=ekont*ees
6981       return
6982       end
6983 #ifdef MOMENT
6984 C---------------------------------------------------------------------------
6985       subroutine dipole(i,j,jj)
6986       implicit real*8 (a-h,o-z)
6987       include 'DIMENSIONS'
6988       include 'COMMON.IOUNITS'
6989       include 'COMMON.CHAIN'
6990       include 'COMMON.FFIELD'
6991       include 'COMMON.DERIV'
6992       include 'COMMON.INTERACT'
6993       include 'COMMON.CONTACTS'
6994       include 'COMMON.TORSION'
6995       include 'COMMON.VAR'
6996       include 'COMMON.GEO'
6997       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6998      &  auxmat(2,2)
6999       iti1 = itortyp(itype(i+1))
7000       if (j.lt.nres-1) then
7001         itj1 = itortyp(itype(j+1))
7002       else
7003         itj1=ntortyp+1
7004       endif
7005       do iii=1,2
7006         dipi(iii,1)=Ub2(iii,i)
7007         dipderi(iii)=Ub2der(iii,i)
7008         dipi(iii,2)=b1(iii,iti1)
7009         dipj(iii,1)=Ub2(iii,j)
7010         dipderj(iii)=Ub2der(iii,j)
7011         dipj(iii,2)=b1(iii,itj1)
7012       enddo
7013       kkk=0
7014       do iii=1,2
7015         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7016         do jjj=1,2
7017           kkk=kkk+1
7018           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7019         enddo
7020       enddo
7021       do kkk=1,5
7022         do lll=1,3
7023           mmm=0
7024           do iii=1,2
7025             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7026      &        auxvec(1))
7027             do jjj=1,2
7028               mmm=mmm+1
7029               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7030             enddo
7031           enddo
7032         enddo
7033       enddo
7034       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7035       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7036       do iii=1,2
7037         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7038       enddo
7039       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7040       do iii=1,2
7041         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7042       enddo
7043       return
7044       end
7045 #endif
7046 C---------------------------------------------------------------------------
7047       subroutine calc_eello(i,j,k,l,jj,kk)
7048 C
7049 C This subroutine computes matrices and vectors needed to calculate
7050 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7051 C
7052       implicit real*8 (a-h,o-z)
7053       include 'DIMENSIONS'
7054       include 'COMMON.IOUNITS'
7055       include 'COMMON.CHAIN'
7056       include 'COMMON.DERIV'
7057       include 'COMMON.INTERACT'
7058       include 'COMMON.CONTACTS'
7059       include 'COMMON.TORSION'
7060       include 'COMMON.VAR'
7061       include 'COMMON.GEO'
7062       include 'COMMON.FFIELD'
7063       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7064      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7065       logical lprn
7066       common /kutas/ lprn
7067 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7068 cd     & ' jj=',jj,' kk=',kk
7069 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7070 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7071 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7072       do iii=1,2
7073         do jjj=1,2
7074           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7075           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7076         enddo
7077       enddo
7078       call transpose2(aa1(1,1),aa1t(1,1))
7079       call transpose2(aa2(1,1),aa2t(1,1))
7080       do kkk=1,5
7081         do lll=1,3
7082           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7083      &      aa1tder(1,1,lll,kkk))
7084           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7085      &      aa2tder(1,1,lll,kkk))
7086         enddo
7087       enddo
7088       if (l.eq.j+1) then
7089 C parallel orientation of the two CA-CA-CA frames.
7090         if (i.gt.1) then
7091           iti=itortyp(itype(i))
7092         else
7093           iti=ntortyp+1
7094         endif
7095         itk1=itortyp(itype(k+1))
7096         itj=itortyp(itype(j))
7097         if (l.lt.nres-1) then
7098           itl1=itortyp(itype(l+1))
7099         else
7100           itl1=ntortyp+1
7101         endif
7102 C A1 kernel(j+1) A2T
7103 cd        do iii=1,2
7104 cd          write (iout,'(3f10.5,5x,3f10.5)')
7105 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7106 cd        enddo
7107         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7108      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7109      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7110 C Following matrices are needed only for 6-th order cumulants
7111         IF (wcorr6.gt.0.0d0) THEN
7112         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7113      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7114      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7115         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7116      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7117      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7118      &   ADtEAderx(1,1,1,1,1,1))
7119         lprn=.false.
7120         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7121      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7122      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7123      &   ADtEA1derx(1,1,1,1,1,1))
7124         ENDIF
7125 C End 6-th order cumulants
7126 cd        lprn=.false.
7127 cd        if (lprn) then
7128 cd        write (2,*) 'In calc_eello6'
7129 cd        do iii=1,2
7130 cd          write (2,*) 'iii=',iii
7131 cd          do kkk=1,5
7132 cd            write (2,*) 'kkk=',kkk
7133 cd            do jjj=1,2
7134 cd              write (2,'(3(2f10.5),5x)')
7135 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7136 cd            enddo
7137 cd          enddo
7138 cd        enddo
7139 cd        endif
7140         call transpose2(EUgder(1,1,k),auxmat(1,1))
7141         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7142         call transpose2(EUg(1,1,k),auxmat(1,1))
7143         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7144         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7145         do iii=1,2
7146           do kkk=1,5
7147             do lll=1,3
7148               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7149      &          EAEAderx(1,1,lll,kkk,iii,1))
7150             enddo
7151           enddo
7152         enddo
7153 C A1T kernel(i+1) A2
7154         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7155      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7156      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7157 C Following matrices are needed only for 6-th order cumulants
7158         IF (wcorr6.gt.0.0d0) THEN
7159         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7160      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7161      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7162         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7163      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7164      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7165      &   ADtEAderx(1,1,1,1,1,2))
7166         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7167      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7168      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7169      &   ADtEA1derx(1,1,1,1,1,2))
7170         ENDIF
7171 C End 6-th order cumulants
7172         call transpose2(EUgder(1,1,l),auxmat(1,1))
7173         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7174         call transpose2(EUg(1,1,l),auxmat(1,1))
7175         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7176         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7177         do iii=1,2
7178           do kkk=1,5
7179             do lll=1,3
7180               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7181      &          EAEAderx(1,1,lll,kkk,iii,2))
7182             enddo
7183           enddo
7184         enddo
7185 C AEAb1 and AEAb2
7186 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7187 C They are needed only when the fifth- or the sixth-order cumulants are
7188 C indluded.
7189         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7190         call transpose2(AEA(1,1,1),auxmat(1,1))
7191         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7192         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7193         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7194         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7195         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7196         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7197         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7198         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7199         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7200         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7201         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7202         call transpose2(AEA(1,1,2),auxmat(1,1))
7203         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7204         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7205         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7206         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7207         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7208         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7209         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7210         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7211         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7212         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7213         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7214 C Calculate the Cartesian derivatives of the vectors.
7215         do iii=1,2
7216           do kkk=1,5
7217             do lll=1,3
7218               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7219               call matvec2(auxmat(1,1),b1(1,iti),
7220      &          AEAb1derx(1,lll,kkk,iii,1,1))
7221               call matvec2(auxmat(1,1),Ub2(1,i),
7222      &          AEAb2derx(1,lll,kkk,iii,1,1))
7223               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7224      &          AEAb1derx(1,lll,kkk,iii,2,1))
7225               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7226      &          AEAb2derx(1,lll,kkk,iii,2,1))
7227               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7228               call matvec2(auxmat(1,1),b1(1,itj),
7229      &          AEAb1derx(1,lll,kkk,iii,1,2))
7230               call matvec2(auxmat(1,1),Ub2(1,j),
7231      &          AEAb2derx(1,lll,kkk,iii,1,2))
7232               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7233      &          AEAb1derx(1,lll,kkk,iii,2,2))
7234               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7235      &          AEAb2derx(1,lll,kkk,iii,2,2))
7236             enddo
7237           enddo
7238         enddo
7239         ENDIF
7240 C End vectors
7241       else
7242 C Antiparallel orientation of the two CA-CA-CA frames.
7243         if (i.gt.1) then
7244           iti=itortyp(itype(i))
7245         else
7246           iti=ntortyp+1
7247         endif
7248         itk1=itortyp(itype(k+1))
7249         itl=itortyp(itype(l))
7250         itj=itortyp(itype(j))
7251         if (j.lt.nres-1) then
7252           itj1=itortyp(itype(j+1))
7253         else
7254           itj1=ntortyp+1
7255         endif
7256 C A2 kernel(j-1)T A1T
7257         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7258      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7259      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7260 C Following matrices are needed only for 6-th order cumulants
7261         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7262      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7263         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7264      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7265      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7266         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7267      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7268      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7269      &   ADtEAderx(1,1,1,1,1,1))
7270         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7271      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7272      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7273      &   ADtEA1derx(1,1,1,1,1,1))
7274         ENDIF
7275 C End 6-th order cumulants
7276         call transpose2(EUgder(1,1,k),auxmat(1,1))
7277         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7278         call transpose2(EUg(1,1,k),auxmat(1,1))
7279         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7280         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7281         do iii=1,2
7282           do kkk=1,5
7283             do lll=1,3
7284               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7285      &          EAEAderx(1,1,lll,kkk,iii,1))
7286             enddo
7287           enddo
7288         enddo
7289 C A2T kernel(i+1)T A1
7290         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7291      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7292      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7293 C Following matrices are needed only for 6-th order cumulants
7294         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7295      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7296         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7297      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7298      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7299         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7300      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7301      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7302      &   ADtEAderx(1,1,1,1,1,2))
7303         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7304      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7305      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7306      &   ADtEA1derx(1,1,1,1,1,2))
7307         ENDIF
7308 C End 6-th order cumulants
7309         call transpose2(EUgder(1,1,j),auxmat(1,1))
7310         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7311         call transpose2(EUg(1,1,j),auxmat(1,1))
7312         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7313         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7314         do iii=1,2
7315           do kkk=1,5
7316             do lll=1,3
7317               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7318      &          EAEAderx(1,1,lll,kkk,iii,2))
7319             enddo
7320           enddo
7321         enddo
7322 C AEAb1 and AEAb2
7323 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7324 C They are needed only when the fifth- or the sixth-order cumulants are
7325 C indluded.
7326         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7327      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7328         call transpose2(AEA(1,1,1),auxmat(1,1))
7329         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7330         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7331         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7332         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7333         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7334         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7335         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7336         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7337         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7338         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7339         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7340         call transpose2(AEA(1,1,2),auxmat(1,1))
7341         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7342         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7343         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7344         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7345         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7346         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7347         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7348         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7349         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7350         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7351         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7352 C Calculate the Cartesian derivatives of the vectors.
7353         do iii=1,2
7354           do kkk=1,5
7355             do lll=1,3
7356               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7357               call matvec2(auxmat(1,1),b1(1,iti),
7358      &          AEAb1derx(1,lll,kkk,iii,1,1))
7359               call matvec2(auxmat(1,1),Ub2(1,i),
7360      &          AEAb2derx(1,lll,kkk,iii,1,1))
7361               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7362      &          AEAb1derx(1,lll,kkk,iii,2,1))
7363               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7364      &          AEAb2derx(1,lll,kkk,iii,2,1))
7365               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7366               call matvec2(auxmat(1,1),b1(1,itl),
7367      &          AEAb1derx(1,lll,kkk,iii,1,2))
7368               call matvec2(auxmat(1,1),Ub2(1,l),
7369      &          AEAb2derx(1,lll,kkk,iii,1,2))
7370               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7371      &          AEAb1derx(1,lll,kkk,iii,2,2))
7372               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7373      &          AEAb2derx(1,lll,kkk,iii,2,2))
7374             enddo
7375           enddo
7376         enddo
7377         ENDIF
7378 C End vectors
7379       endif
7380       return
7381       end
7382 C---------------------------------------------------------------------------
7383       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7384      &  KK,KKderg,AKA,AKAderg,AKAderx)
7385       implicit none
7386       integer nderg
7387       logical transp
7388       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7389      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7390      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7391       integer iii,kkk,lll
7392       integer jjj,mmm
7393       logical lprn
7394       common /kutas/ lprn
7395       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7396       do iii=1,nderg
7397         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7398      &    AKAderg(1,1,iii))
7399       enddo
7400 cd      if (lprn) write (2,*) 'In kernel'
7401       do kkk=1,5
7402 cd        if (lprn) write (2,*) 'kkk=',kkk
7403         do lll=1,3
7404           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7405      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7406 cd          if (lprn) then
7407 cd            write (2,*) 'lll=',lll
7408 cd            write (2,*) 'iii=1'
7409 cd            do jjj=1,2
7410 cd              write (2,'(3(2f10.5),5x)')
7411 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7412 cd            enddo
7413 cd          endif
7414           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7415      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7416 cd          if (lprn) then
7417 cd            write (2,*) 'lll=',lll
7418 cd            write (2,*) 'iii=2'
7419 cd            do jjj=1,2
7420 cd              write (2,'(3(2f10.5),5x)')
7421 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7422 cd            enddo
7423 cd          endif
7424         enddo
7425       enddo
7426       return
7427       end
7428 C---------------------------------------------------------------------------
7429       double precision function eello4(i,j,k,l,jj,kk)
7430       implicit real*8 (a-h,o-z)
7431       include 'DIMENSIONS'
7432       include 'COMMON.IOUNITS'
7433       include 'COMMON.CHAIN'
7434       include 'COMMON.DERIV'
7435       include 'COMMON.INTERACT'
7436       include 'COMMON.CONTACTS'
7437       include 'COMMON.TORSION'
7438       include 'COMMON.VAR'
7439       include 'COMMON.GEO'
7440       double precision pizda(2,2),ggg1(3),ggg2(3)
7441 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7442 cd        eello4=0.0d0
7443 cd        return
7444 cd      endif
7445 cd      print *,'eello4:',i,j,k,l,jj,kk
7446 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7447 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7448 cold      eij=facont_hb(jj,i)
7449 cold      ekl=facont_hb(kk,k)
7450 cold      ekont=eij*ekl
7451       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7452 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7453       gcorr_loc(k-1)=gcorr_loc(k-1)
7454      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7455       if (l.eq.j+1) then
7456         gcorr_loc(l-1)=gcorr_loc(l-1)
7457      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7458       else
7459         gcorr_loc(j-1)=gcorr_loc(j-1)
7460      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7461       endif
7462       do iii=1,2
7463         do kkk=1,5
7464           do lll=1,3
7465             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7466      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7467 cd            derx(lll,kkk,iii)=0.0d0
7468           enddo
7469         enddo
7470       enddo
7471 cd      gcorr_loc(l-1)=0.0d0
7472 cd      gcorr_loc(j-1)=0.0d0
7473 cd      gcorr_loc(k-1)=0.0d0
7474 cd      eel4=1.0d0
7475 cd      write (iout,*)'Contacts have occurred for peptide groups',
7476 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7477 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7478       if (j.lt.nres-1) then
7479         j1=j+1
7480         j2=j-1
7481       else
7482         j1=j-1
7483         j2=j-2
7484       endif
7485       if (l.lt.nres-1) then
7486         l1=l+1
7487         l2=l-1
7488       else
7489         l1=l-1
7490         l2=l-2
7491       endif
7492       do ll=1,3
7493 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7494 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7495         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7496         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7497 cgrad        ghalf=0.5d0*ggg1(ll)
7498         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7499         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7500         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7501         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7502         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7503         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7504 cgrad        ghalf=0.5d0*ggg2(ll)
7505         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7506         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7507         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7508         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7509         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7510         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7511       enddo
7512 cgrad      do m=i+1,j-1
7513 cgrad        do ll=1,3
7514 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7515 cgrad        enddo
7516 cgrad      enddo
7517 cgrad      do m=k+1,l-1
7518 cgrad        do ll=1,3
7519 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7520 cgrad        enddo
7521 cgrad      enddo
7522 cgrad      do m=i+2,j2
7523 cgrad        do ll=1,3
7524 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7525 cgrad        enddo
7526 cgrad      enddo
7527 cgrad      do m=k+2,l2
7528 cgrad        do ll=1,3
7529 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7530 cgrad        enddo
7531 cgrad      enddo
7532 cd      do iii=1,nres-3
7533 cd        write (2,*) iii,gcorr_loc(iii)
7534 cd      enddo
7535       eello4=ekont*eel4
7536 cd      write (2,*) 'ekont',ekont
7537 cd      write (iout,*) 'eello4',ekont*eel4
7538       return
7539       end
7540 C---------------------------------------------------------------------------
7541       double precision function eello5(i,j,k,l,jj,kk)
7542       implicit real*8 (a-h,o-z)
7543       include 'DIMENSIONS'
7544       include 'COMMON.IOUNITS'
7545       include 'COMMON.CHAIN'
7546       include 'COMMON.DERIV'
7547       include 'COMMON.INTERACT'
7548       include 'COMMON.CONTACTS'
7549       include 'COMMON.TORSION'
7550       include 'COMMON.VAR'
7551       include 'COMMON.GEO'
7552       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7553       double precision ggg1(3),ggg2(3)
7554 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7555 C                                                                              C
7556 C                            Parallel chains                                   C
7557 C                                                                              C
7558 C          o             o                   o             o                   C
7559 C         /l\           / \             \   / \           / \   /              C
7560 C        /   \         /   \             \ /   \         /   \ /               C
7561 C       j| o |l1       | o |              o| o |         | o |o                C
7562 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7563 C      \i/   \         /   \ /             /   \         /   \                 C
7564 C       o    k1             o                                                  C
7565 C         (I)          (II)                (III)          (IV)                 C
7566 C                                                                              C
7567 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7568 C                                                                              C
7569 C                            Antiparallel chains                               C
7570 C                                                                              C
7571 C          o             o                   o             o                   C
7572 C         /j\           / \             \   / \           / \   /              C
7573 C        /   \         /   \             \ /   \         /   \ /               C
7574 C      j1| o |l        | o |              o| o |         | o |o                C
7575 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7576 C      \i/   \         /   \ /             /   \         /   \                 C
7577 C       o     k1            o                                                  C
7578 C         (I)          (II)                (III)          (IV)                 C
7579 C                                                                              C
7580 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7581 C                                                                              C
7582 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7583 C                                                                              C
7584 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7585 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7586 cd        eello5=0.0d0
7587 cd        return
7588 cd      endif
7589 cd      write (iout,*)
7590 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7591 cd     &   ' and',k,l
7592       itk=itortyp(itype(k))
7593       itl=itortyp(itype(l))
7594       itj=itortyp(itype(j))
7595       eello5_1=0.0d0
7596       eello5_2=0.0d0
7597       eello5_3=0.0d0
7598       eello5_4=0.0d0
7599 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7600 cd     &   eel5_3_num,eel5_4_num)
7601       do iii=1,2
7602         do kkk=1,5
7603           do lll=1,3
7604             derx(lll,kkk,iii)=0.0d0
7605           enddo
7606         enddo
7607       enddo
7608 cd      eij=facont_hb(jj,i)
7609 cd      ekl=facont_hb(kk,k)
7610 cd      ekont=eij*ekl
7611 cd      write (iout,*)'Contacts have occurred for peptide groups',
7612 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7613 cd      goto 1111
7614 C Contribution from the graph I.
7615 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7616 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7617       call transpose2(EUg(1,1,k),auxmat(1,1))
7618       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7619       vv(1)=pizda(1,1)-pizda(2,2)
7620       vv(2)=pizda(1,2)+pizda(2,1)
7621       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7622      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7623 C Explicit gradient in virtual-dihedral angles.
7624       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7625      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7626      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7627       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7628       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7629       vv(1)=pizda(1,1)-pizda(2,2)
7630       vv(2)=pizda(1,2)+pizda(2,1)
7631       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7632      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7633      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7634       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7635       vv(1)=pizda(1,1)-pizda(2,2)
7636       vv(2)=pizda(1,2)+pizda(2,1)
7637       if (l.eq.j+1) then
7638         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7639      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7640      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7641       else
7642         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7643      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7644      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7645       endif
7646 C Cartesian gradient
7647       do iii=1,2
7648         do kkk=1,5
7649           do lll=1,3
7650             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7651      &        pizda(1,1))
7652             vv(1)=pizda(1,1)-pizda(2,2)
7653             vv(2)=pizda(1,2)+pizda(2,1)
7654             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7655      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7656      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7657           enddo
7658         enddo
7659       enddo
7660 c      goto 1112
7661 c1111  continue
7662 C Contribution from graph II
7663       call transpose2(EE(1,1,itk),auxmat(1,1))
7664       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7665       vv(1)=pizda(1,1)+pizda(2,2)
7666       vv(2)=pizda(2,1)-pizda(1,2)
7667       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7668      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7669 C Explicit gradient in virtual-dihedral angles.
7670       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7671      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7672       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7673       vv(1)=pizda(1,1)+pizda(2,2)
7674       vv(2)=pizda(2,1)-pizda(1,2)
7675       if (l.eq.j+1) then
7676         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7677      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7678      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7679       else
7680         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7681      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7682      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7683       endif
7684 C Cartesian gradient
7685       do iii=1,2
7686         do kkk=1,5
7687           do lll=1,3
7688             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7689      &        pizda(1,1))
7690             vv(1)=pizda(1,1)+pizda(2,2)
7691             vv(2)=pizda(2,1)-pizda(1,2)
7692             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7693      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7694      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7695           enddo
7696         enddo
7697       enddo
7698 cd      goto 1112
7699 cd1111  continue
7700       if (l.eq.j+1) then
7701 cd        goto 1110
7702 C Parallel orientation
7703 C Contribution from graph III
7704         call transpose2(EUg(1,1,l),auxmat(1,1))
7705         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7706         vv(1)=pizda(1,1)-pizda(2,2)
7707         vv(2)=pizda(1,2)+pizda(2,1)
7708         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7709      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7710 C Explicit gradient in virtual-dihedral angles.
7711         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7712      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7713      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7714         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7715         vv(1)=pizda(1,1)-pizda(2,2)
7716         vv(2)=pizda(1,2)+pizda(2,1)
7717         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7718      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7719      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7720         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7721         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7722         vv(1)=pizda(1,1)-pizda(2,2)
7723         vv(2)=pizda(1,2)+pizda(2,1)
7724         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7725      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7726      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7727 C Cartesian gradient
7728         do iii=1,2
7729           do kkk=1,5
7730             do lll=1,3
7731               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7732      &          pizda(1,1))
7733               vv(1)=pizda(1,1)-pizda(2,2)
7734               vv(2)=pizda(1,2)+pizda(2,1)
7735               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7736      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7737      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7738             enddo
7739           enddo
7740         enddo
7741 cd        goto 1112
7742 C Contribution from graph IV
7743 cd1110    continue
7744         call transpose2(EE(1,1,itl),auxmat(1,1))
7745         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7746         vv(1)=pizda(1,1)+pizda(2,2)
7747         vv(2)=pizda(2,1)-pizda(1,2)
7748         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7749      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7750 C Explicit gradient in virtual-dihedral angles.
7751         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7752      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7753         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7754         vv(1)=pizda(1,1)+pizda(2,2)
7755         vv(2)=pizda(2,1)-pizda(1,2)
7756         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7757      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7758      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7759 C Cartesian gradient
7760         do iii=1,2
7761           do kkk=1,5
7762             do lll=1,3
7763               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7764      &          pizda(1,1))
7765               vv(1)=pizda(1,1)+pizda(2,2)
7766               vv(2)=pizda(2,1)-pizda(1,2)
7767               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7768      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7769      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7770             enddo
7771           enddo
7772         enddo
7773       else
7774 C Antiparallel orientation
7775 C Contribution from graph III
7776 c        goto 1110
7777         call transpose2(EUg(1,1,j),auxmat(1,1))
7778         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7779         vv(1)=pizda(1,1)-pizda(2,2)
7780         vv(2)=pizda(1,2)+pizda(2,1)
7781         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7782      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7783 C Explicit gradient in virtual-dihedral angles.
7784         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7785      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7786      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7787         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7788         vv(1)=pizda(1,1)-pizda(2,2)
7789         vv(2)=pizda(1,2)+pizda(2,1)
7790         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7791      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7792      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7793         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7794         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7795         vv(1)=pizda(1,1)-pizda(2,2)
7796         vv(2)=pizda(1,2)+pizda(2,1)
7797         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7798      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7799      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7800 C Cartesian gradient
7801         do iii=1,2
7802           do kkk=1,5
7803             do lll=1,3
7804               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7805      &          pizda(1,1))
7806               vv(1)=pizda(1,1)-pizda(2,2)
7807               vv(2)=pizda(1,2)+pizda(2,1)
7808               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7809      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7810      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7811             enddo
7812           enddo
7813         enddo
7814 cd        goto 1112
7815 C Contribution from graph IV
7816 1110    continue
7817         call transpose2(EE(1,1,itj),auxmat(1,1))
7818         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7819         vv(1)=pizda(1,1)+pizda(2,2)
7820         vv(2)=pizda(2,1)-pizda(1,2)
7821         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7822      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7823 C Explicit gradient in virtual-dihedral angles.
7824         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7825      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7826         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7827         vv(1)=pizda(1,1)+pizda(2,2)
7828         vv(2)=pizda(2,1)-pizda(1,2)
7829         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7830      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7831      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7832 C Cartesian gradient
7833         do iii=1,2
7834           do kkk=1,5
7835             do lll=1,3
7836               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7837      &          pizda(1,1))
7838               vv(1)=pizda(1,1)+pizda(2,2)
7839               vv(2)=pizda(2,1)-pizda(1,2)
7840               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7841      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7842      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7843             enddo
7844           enddo
7845         enddo
7846       endif
7847 1112  continue
7848       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7849 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7850 cd        write (2,*) 'ijkl',i,j,k,l
7851 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7852 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7853 cd      endif
7854 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7855 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7856 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7857 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7858       if (j.lt.nres-1) then
7859         j1=j+1
7860         j2=j-1
7861       else
7862         j1=j-1
7863         j2=j-2
7864       endif
7865       if (l.lt.nres-1) then
7866         l1=l+1
7867         l2=l-1
7868       else
7869         l1=l-1
7870         l2=l-2
7871       endif
7872 cd      eij=1.0d0
7873 cd      ekl=1.0d0
7874 cd      ekont=1.0d0
7875 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7876 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7877 C        summed up outside the subrouine as for the other subroutines
7878 C        handling long-range interactions. The old code is commented out
7879 C        with "cgrad" to keep track of changes.
7880       do ll=1,3
7881 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7882 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7883         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7884         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7885 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7886 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7887 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7888 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7889 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7890 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7891 c     &   gradcorr5ij,
7892 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7893 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7894 cgrad        ghalf=0.5d0*ggg1(ll)
7895 cd        ghalf=0.0d0
7896         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7897         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7898         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7899         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7900         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7901         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7902 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7903 cgrad        ghalf=0.5d0*ggg2(ll)
7904 cd        ghalf=0.0d0
7905         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7906         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7907         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7908         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7909         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7910         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7911       enddo
7912 cd      goto 1112
7913 cgrad      do m=i+1,j-1
7914 cgrad        do ll=1,3
7915 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7916 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7917 cgrad        enddo
7918 cgrad      enddo
7919 cgrad      do m=k+1,l-1
7920 cgrad        do ll=1,3
7921 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7922 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7923 cgrad        enddo
7924 cgrad      enddo
7925 c1112  continue
7926 cgrad      do m=i+2,j2
7927 cgrad        do ll=1,3
7928 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7929 cgrad        enddo
7930 cgrad      enddo
7931 cgrad      do m=k+2,l2
7932 cgrad        do ll=1,3
7933 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7934 cgrad        enddo
7935 cgrad      enddo
7936 cd      do iii=1,nres-3
7937 cd        write (2,*) iii,g_corr5_loc(iii)
7938 cd      enddo
7939       eello5=ekont*eel5
7940 cd      write (2,*) 'ekont',ekont
7941 cd      write (iout,*) 'eello5',ekont*eel5
7942       return
7943       end
7944 c--------------------------------------------------------------------------
7945       double precision function eello6(i,j,k,l,jj,kk)
7946       implicit real*8 (a-h,o-z)
7947       include 'DIMENSIONS'
7948       include 'COMMON.IOUNITS'
7949       include 'COMMON.CHAIN'
7950       include 'COMMON.DERIV'
7951       include 'COMMON.INTERACT'
7952       include 'COMMON.CONTACTS'
7953       include 'COMMON.TORSION'
7954       include 'COMMON.VAR'
7955       include 'COMMON.GEO'
7956       include 'COMMON.FFIELD'
7957       double precision ggg1(3),ggg2(3)
7958 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7959 cd        eello6=0.0d0
7960 cd        return
7961 cd      endif
7962 cd      write (iout,*)
7963 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7964 cd     &   ' and',k,l
7965       eello6_1=0.0d0
7966       eello6_2=0.0d0
7967       eello6_3=0.0d0
7968       eello6_4=0.0d0
7969       eello6_5=0.0d0
7970       eello6_6=0.0d0
7971 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7972 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7973       do iii=1,2
7974         do kkk=1,5
7975           do lll=1,3
7976             derx(lll,kkk,iii)=0.0d0
7977           enddo
7978         enddo
7979       enddo
7980 cd      eij=facont_hb(jj,i)
7981 cd      ekl=facont_hb(kk,k)
7982 cd      ekont=eij*ekl
7983 cd      eij=1.0d0
7984 cd      ekl=1.0d0
7985 cd      ekont=1.0d0
7986       if (l.eq.j+1) then
7987         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7988         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7989         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7990         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7991         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7992         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7993       else
7994         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7995         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7996         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7997         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7998         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7999           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8000         else
8001           eello6_5=0.0d0
8002         endif
8003         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8004       endif
8005 C If turn contributions are considered, they will be handled separately.
8006       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8007 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8008 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8009 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8010 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8011 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8012 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8013 cd      goto 1112
8014       if (j.lt.nres-1) then
8015         j1=j+1
8016         j2=j-1
8017       else
8018         j1=j-1
8019         j2=j-2
8020       endif
8021       if (l.lt.nres-1) then
8022         l1=l+1
8023         l2=l-1
8024       else
8025         l1=l-1
8026         l2=l-2
8027       endif
8028       do ll=1,3
8029 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8030 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8031 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8032 cgrad        ghalf=0.5d0*ggg1(ll)
8033 cd        ghalf=0.0d0
8034         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8035         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8036         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8037         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8038         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8039         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8040         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8041         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8042 cgrad        ghalf=0.5d0*ggg2(ll)
8043 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8044 cd        ghalf=0.0d0
8045         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8046         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8047         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8048         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8049         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8050         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8051       enddo
8052 cd      goto 1112
8053 cgrad      do m=i+1,j-1
8054 cgrad        do ll=1,3
8055 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8056 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8057 cgrad        enddo
8058 cgrad      enddo
8059 cgrad      do m=k+1,l-1
8060 cgrad        do ll=1,3
8061 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8062 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8063 cgrad        enddo
8064 cgrad      enddo
8065 cgrad1112  continue
8066 cgrad      do m=i+2,j2
8067 cgrad        do ll=1,3
8068 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8069 cgrad        enddo
8070 cgrad      enddo
8071 cgrad      do m=k+2,l2
8072 cgrad        do ll=1,3
8073 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8074 cgrad        enddo
8075 cgrad      enddo
8076 cd      do iii=1,nres-3
8077 cd        write (2,*) iii,g_corr6_loc(iii)
8078 cd      enddo
8079       eello6=ekont*eel6
8080 cd      write (2,*) 'ekont',ekont
8081 cd      write (iout,*) 'eello6',ekont*eel6
8082       return
8083       end
8084 c--------------------------------------------------------------------------
8085       double precision function eello6_graph1(i,j,k,l,imat,swap)
8086       implicit real*8 (a-h,o-z)
8087       include 'DIMENSIONS'
8088       include 'COMMON.IOUNITS'
8089       include 'COMMON.CHAIN'
8090       include 'COMMON.DERIV'
8091       include 'COMMON.INTERACT'
8092       include 'COMMON.CONTACTS'
8093       include 'COMMON.TORSION'
8094       include 'COMMON.VAR'
8095       include 'COMMON.GEO'
8096       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8097       logical swap
8098       logical lprn
8099       common /kutas/ lprn
8100 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8101 C
8102 C      Parallel       Antiparallel
8103 C
8104 C          o             o
8105 C         /l\           /j\
8106 C        /   \         /   \
8107 C       /| o |         | o |\
8108 C     \ j|/k\|  /   \  |/k\|l /
8109 C      \ /   \ /     \ /   \ /
8110 C       o     o       o     o
8111 C       i             i
8112 C
8113 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8114       itk=itortyp(itype(k))
8115       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8116       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8117       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8118       call transpose2(EUgC(1,1,k),auxmat(1,1))
8119       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8120       vv1(1)=pizda1(1,1)-pizda1(2,2)
8121       vv1(2)=pizda1(1,2)+pizda1(2,1)
8122       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8123       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8124       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8125       s5=scalar2(vv(1),Dtobr2(1,i))
8126 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8127       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8128       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8129      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8130      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8131      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8132      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8133      & +scalar2(vv(1),Dtobr2der(1,i)))
8134       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8135       vv1(1)=pizda1(1,1)-pizda1(2,2)
8136       vv1(2)=pizda1(1,2)+pizda1(2,1)
8137       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8138       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8139       if (l.eq.j+1) then
8140         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8141      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8142      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8143      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8144      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8145       else
8146         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8147      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8148      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8149      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8150      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8151       endif
8152       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8153       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8154       vv1(1)=pizda1(1,1)-pizda1(2,2)
8155       vv1(2)=pizda1(1,2)+pizda1(2,1)
8156       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8157      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8158      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8159      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8160       do iii=1,2
8161         if (swap) then
8162           ind=3-iii
8163         else
8164           ind=iii
8165         endif
8166         do kkk=1,5
8167           do lll=1,3
8168             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8169             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8170             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8171             call transpose2(EUgC(1,1,k),auxmat(1,1))
8172             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8173      &        pizda1(1,1))
8174             vv1(1)=pizda1(1,1)-pizda1(2,2)
8175             vv1(2)=pizda1(1,2)+pizda1(2,1)
8176             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8177             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8178      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8179             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8180      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8181             s5=scalar2(vv(1),Dtobr2(1,i))
8182             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8183           enddo
8184         enddo
8185       enddo
8186       return
8187       end
8188 c----------------------------------------------------------------------------
8189       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8190       implicit real*8 (a-h,o-z)
8191       include 'DIMENSIONS'
8192       include 'COMMON.IOUNITS'
8193       include 'COMMON.CHAIN'
8194       include 'COMMON.DERIV'
8195       include 'COMMON.INTERACT'
8196       include 'COMMON.CONTACTS'
8197       include 'COMMON.TORSION'
8198       include 'COMMON.VAR'
8199       include 'COMMON.GEO'
8200       logical swap
8201       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8202      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8203       logical lprn
8204       common /kutas/ lprn
8205 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8206 C                                                                              C
8207 C      Parallel       Antiparallel                                             C
8208 C                                                                              C
8209 C          o             o                                                     C
8210 C     \   /l\           /j\   /                                                C
8211 C      \ /   \         /   \ /                                                 C
8212 C       o| o |         | o |o                                                  C
8213 C     \ j|/k\|      \  |/k\|l                                                  C
8214 C      \ /   \       \ /   \                                                   C
8215 C       o             o                                                        C
8216 C       i             i                                                        C
8217 C                                                                              C
8218 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8219 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8220 C AL 7/4/01 s1 would occur in the sixth-order moment,
8221 C           but not in a cluster cumulant
8222 #ifdef MOMENT
8223       s1=dip(1,jj,i)*dip(1,kk,k)
8224 #endif
8225       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8226       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8227       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8228       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8229       call transpose2(EUg(1,1,k),auxmat(1,1))
8230       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8231       vv(1)=pizda(1,1)-pizda(2,2)
8232       vv(2)=pizda(1,2)+pizda(2,1)
8233       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8234 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8235 #ifdef MOMENT
8236       eello6_graph2=-(s1+s2+s3+s4)
8237 #else
8238       eello6_graph2=-(s2+s3+s4)
8239 #endif
8240 c      eello6_graph2=-s3
8241 C Derivatives in gamma(i-1)
8242       if (i.gt.1) then
8243 #ifdef MOMENT
8244         s1=dipderg(1,jj,i)*dip(1,kk,k)
8245 #endif
8246         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8247         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8248         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8249         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8250 #ifdef MOMENT
8251         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8252 #else
8253         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8254 #endif
8255 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8256       endif
8257 C Derivatives in gamma(k-1)
8258 #ifdef MOMENT
8259       s1=dip(1,jj,i)*dipderg(1,kk,k)
8260 #endif
8261       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8262       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8263       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8264       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8265       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8266       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8267       vv(1)=pizda(1,1)-pizda(2,2)
8268       vv(2)=pizda(1,2)+pizda(2,1)
8269       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8270 #ifdef MOMENT
8271       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8272 #else
8273       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8274 #endif
8275 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8276 C Derivatives in gamma(j-1) or gamma(l-1)
8277       if (j.gt.1) then
8278 #ifdef MOMENT
8279         s1=dipderg(3,jj,i)*dip(1,kk,k)
8280 #endif
8281         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8282         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8283         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8284         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8285         vv(1)=pizda(1,1)-pizda(2,2)
8286         vv(2)=pizda(1,2)+pizda(2,1)
8287         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8288 #ifdef MOMENT
8289         if (swap) then
8290           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8291         else
8292           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8293         endif
8294 #endif
8295         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8296 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8297       endif
8298 C Derivatives in gamma(l-1) or gamma(j-1)
8299       if (l.gt.1) then
8300 #ifdef MOMENT
8301         s1=dip(1,jj,i)*dipderg(3,kk,k)
8302 #endif
8303         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8304         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8305         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8306         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8307         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8308         vv(1)=pizda(1,1)-pizda(2,2)
8309         vv(2)=pizda(1,2)+pizda(2,1)
8310         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8311 #ifdef MOMENT
8312         if (swap) then
8313           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8314         else
8315           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8316         endif
8317 #endif
8318         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8319 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8320       endif
8321 C Cartesian derivatives.
8322       if (lprn) then
8323         write (2,*) 'In eello6_graph2'
8324         do iii=1,2
8325           write (2,*) 'iii=',iii
8326           do kkk=1,5
8327             write (2,*) 'kkk=',kkk
8328             do jjj=1,2
8329               write (2,'(3(2f10.5),5x)')
8330      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8331             enddo
8332           enddo
8333         enddo
8334       endif
8335       do iii=1,2
8336         do kkk=1,5
8337           do lll=1,3
8338 #ifdef MOMENT
8339             if (iii.eq.1) then
8340               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8341             else
8342               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8343             endif
8344 #endif
8345             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8346      &        auxvec(1))
8347             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8348             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8349      &        auxvec(1))
8350             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8351             call transpose2(EUg(1,1,k),auxmat(1,1))
8352             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8353      &        pizda(1,1))
8354             vv(1)=pizda(1,1)-pizda(2,2)
8355             vv(2)=pizda(1,2)+pizda(2,1)
8356             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8357 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8358 #ifdef MOMENT
8359             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8360 #else
8361             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8362 #endif
8363             if (swap) then
8364               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8365             else
8366               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8367             endif
8368           enddo
8369         enddo
8370       enddo
8371       return
8372       end
8373 c----------------------------------------------------------------------------
8374       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8375       implicit real*8 (a-h,o-z)
8376       include 'DIMENSIONS'
8377       include 'COMMON.IOUNITS'
8378       include 'COMMON.CHAIN'
8379       include 'COMMON.DERIV'
8380       include 'COMMON.INTERACT'
8381       include 'COMMON.CONTACTS'
8382       include 'COMMON.TORSION'
8383       include 'COMMON.VAR'
8384       include 'COMMON.GEO'
8385       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8386       logical swap
8387 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8388 C                                                                              C
8389 C      Parallel       Antiparallel                                             C
8390 C                                                                              C
8391 C          o             o                                                     C
8392 C         /l\   /   \   /j\                                                    C
8393 C        /   \ /     \ /   \                                                   C
8394 C       /| o |o       o| o |\                                                  C
8395 C       j|/k\|  /      |/k\|l /                                                C
8396 C        /   \ /       /   \ /                                                 C
8397 C       /     o       /     o                                                  C
8398 C       i             i                                                        C
8399 C                                                                              C
8400 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8401 C
8402 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8403 C           energy moment and not to the cluster cumulant.
8404       iti=itortyp(itype(i))
8405       if (j.lt.nres-1) then
8406         itj1=itortyp(itype(j+1))
8407       else
8408         itj1=ntortyp+1
8409       endif
8410       itk=itortyp(itype(k))
8411       itk1=itortyp(itype(k+1))
8412       if (l.lt.nres-1) then
8413         itl1=itortyp(itype(l+1))
8414       else
8415         itl1=ntortyp+1
8416       endif
8417 #ifdef MOMENT
8418       s1=dip(4,jj,i)*dip(4,kk,k)
8419 #endif
8420       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8421       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8422       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8423       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8424       call transpose2(EE(1,1,itk),auxmat(1,1))
8425       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8426       vv(1)=pizda(1,1)+pizda(2,2)
8427       vv(2)=pizda(2,1)-pizda(1,2)
8428       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8429 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8430 cd     & "sum",-(s2+s3+s4)
8431 #ifdef MOMENT
8432       eello6_graph3=-(s1+s2+s3+s4)
8433 #else
8434       eello6_graph3=-(s2+s3+s4)
8435 #endif
8436 c      eello6_graph3=-s4
8437 C Derivatives in gamma(k-1)
8438       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8439       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8440       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8441       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8442 C Derivatives in gamma(l-1)
8443       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8444       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8445       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8446       vv(1)=pizda(1,1)+pizda(2,2)
8447       vv(2)=pizda(2,1)-pizda(1,2)
8448       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8449       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8450 C Cartesian derivatives.
8451       do iii=1,2
8452         do kkk=1,5
8453           do lll=1,3
8454 #ifdef MOMENT
8455             if (iii.eq.1) then
8456               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8457             else
8458               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8459             endif
8460 #endif
8461             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8462      &        auxvec(1))
8463             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8464             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8465      &        auxvec(1))
8466             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8467             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8468      &        pizda(1,1))
8469             vv(1)=pizda(1,1)+pizda(2,2)
8470             vv(2)=pizda(2,1)-pizda(1,2)
8471             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8472 #ifdef MOMENT
8473             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8474 #else
8475             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8476 #endif
8477             if (swap) then
8478               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8479             else
8480               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8481             endif
8482 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8483           enddo
8484         enddo
8485       enddo
8486       return
8487       end
8488 c----------------------------------------------------------------------------
8489       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8490       implicit real*8 (a-h,o-z)
8491       include 'DIMENSIONS'
8492       include 'COMMON.IOUNITS'
8493       include 'COMMON.CHAIN'
8494       include 'COMMON.DERIV'
8495       include 'COMMON.INTERACT'
8496       include 'COMMON.CONTACTS'
8497       include 'COMMON.TORSION'
8498       include 'COMMON.VAR'
8499       include 'COMMON.GEO'
8500       include 'COMMON.FFIELD'
8501       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8502      & auxvec1(2),auxmat1(2,2)
8503       logical swap
8504 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8505 C                                                                              C
8506 C      Parallel       Antiparallel                                             C
8507 C                                                                              C
8508 C          o             o                                                     C
8509 C         /l\   /   \   /j\                                                    C
8510 C        /   \ /     \ /   \                                                   C
8511 C       /| o |o       o| o |\                                                  C
8512 C     \ j|/k\|      \  |/k\|l                                                  C
8513 C      \ /   \       \ /   \                                                   C
8514 C       o     \       o     \                                                  C
8515 C       i             i                                                        C
8516 C                                                                              C
8517 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8518 C
8519 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8520 C           energy moment and not to the cluster cumulant.
8521 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8522       iti=itortyp(itype(i))
8523       itj=itortyp(itype(j))
8524       if (j.lt.nres-1) then
8525         itj1=itortyp(itype(j+1))
8526       else
8527         itj1=ntortyp+1
8528       endif
8529       itk=itortyp(itype(k))
8530       if (k.lt.nres-1) then
8531         itk1=itortyp(itype(k+1))
8532       else
8533         itk1=ntortyp+1
8534       endif
8535       itl=itortyp(itype(l))
8536       if (l.lt.nres-1) then
8537         itl1=itortyp(itype(l+1))
8538       else
8539         itl1=ntortyp+1
8540       endif
8541 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8542 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8543 cd     & ' itl',itl,' itl1',itl1
8544 #ifdef MOMENT
8545       if (imat.eq.1) then
8546         s1=dip(3,jj,i)*dip(3,kk,k)
8547       else
8548         s1=dip(2,jj,j)*dip(2,kk,l)
8549       endif
8550 #endif
8551       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8552       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8553       if (j.eq.l+1) then
8554         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8555         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8556       else
8557         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8558         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8559       endif
8560       call transpose2(EUg(1,1,k),auxmat(1,1))
8561       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8562       vv(1)=pizda(1,1)-pizda(2,2)
8563       vv(2)=pizda(2,1)+pizda(1,2)
8564       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8565 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8566 #ifdef MOMENT
8567       eello6_graph4=-(s1+s2+s3+s4)
8568 #else
8569       eello6_graph4=-(s2+s3+s4)
8570 #endif
8571 C Derivatives in gamma(i-1)
8572       if (i.gt.1) then
8573 #ifdef MOMENT
8574         if (imat.eq.1) then
8575           s1=dipderg(2,jj,i)*dip(3,kk,k)
8576         else
8577           s1=dipderg(4,jj,j)*dip(2,kk,l)
8578         endif
8579 #endif
8580         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8581         if (j.eq.l+1) then
8582           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8583           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8584         else
8585           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8586           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8587         endif
8588         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8589         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8590 cd          write (2,*) 'turn6 derivatives'
8591 #ifdef MOMENT
8592           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8593 #else
8594           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8595 #endif
8596         else
8597 #ifdef MOMENT
8598           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8599 #else
8600           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8601 #endif
8602         endif
8603       endif
8604 C Derivatives in gamma(k-1)
8605 #ifdef MOMENT
8606       if (imat.eq.1) then
8607         s1=dip(3,jj,i)*dipderg(2,kk,k)
8608       else
8609         s1=dip(2,jj,j)*dipderg(4,kk,l)
8610       endif
8611 #endif
8612       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8613       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8614       if (j.eq.l+1) then
8615         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8616         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8617       else
8618         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8619         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8620       endif
8621       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8622       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8623       vv(1)=pizda(1,1)-pizda(2,2)
8624       vv(2)=pizda(2,1)+pizda(1,2)
8625       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8626       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8627 #ifdef MOMENT
8628         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8629 #else
8630         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8631 #endif
8632       else
8633 #ifdef MOMENT
8634         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8635 #else
8636         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8637 #endif
8638       endif
8639 C Derivatives in gamma(j-1) or gamma(l-1)
8640       if (l.eq.j+1 .and. l.gt.1) then
8641         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8642         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8643         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8644         vv(1)=pizda(1,1)-pizda(2,2)
8645         vv(2)=pizda(2,1)+pizda(1,2)
8646         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8647         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8648       else if (j.gt.1) then
8649         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8650         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8651         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8652         vv(1)=pizda(1,1)-pizda(2,2)
8653         vv(2)=pizda(2,1)+pizda(1,2)
8654         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8655         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8656           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8657         else
8658           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8659         endif
8660       endif
8661 C Cartesian derivatives.
8662       do iii=1,2
8663         do kkk=1,5
8664           do lll=1,3
8665 #ifdef MOMENT
8666             if (iii.eq.1) then
8667               if (imat.eq.1) then
8668                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8669               else
8670                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8671               endif
8672             else
8673               if (imat.eq.1) then
8674                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8675               else
8676                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8677               endif
8678             endif
8679 #endif
8680             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8681      &        auxvec(1))
8682             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8683             if (j.eq.l+1) then
8684               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8685      &          b1(1,itj1),auxvec(1))
8686               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8687             else
8688               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8689      &          b1(1,itl1),auxvec(1))
8690               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8691             endif
8692             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8693      &        pizda(1,1))
8694             vv(1)=pizda(1,1)-pizda(2,2)
8695             vv(2)=pizda(2,1)+pizda(1,2)
8696             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8697             if (swap) then
8698               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8699 #ifdef MOMENT
8700                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8701      &             -(s1+s2+s4)
8702 #else
8703                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8704      &             -(s2+s4)
8705 #endif
8706                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8707               else
8708 #ifdef MOMENT
8709                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8710 #else
8711                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8712 #endif
8713                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8714               endif
8715             else
8716 #ifdef MOMENT
8717               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8718 #else
8719               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8720 #endif
8721               if (l.eq.j+1) then
8722                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8723               else
8724                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8725               endif
8726             endif
8727           enddo
8728         enddo
8729       enddo
8730       return
8731       end
8732 c----------------------------------------------------------------------------
8733       double precision function eello_turn6(i,jj,kk)
8734       implicit real*8 (a-h,o-z)
8735       include 'DIMENSIONS'
8736       include 'COMMON.IOUNITS'
8737       include 'COMMON.CHAIN'
8738       include 'COMMON.DERIV'
8739       include 'COMMON.INTERACT'
8740       include 'COMMON.CONTACTS'
8741       include 'COMMON.TORSION'
8742       include 'COMMON.VAR'
8743       include 'COMMON.GEO'
8744       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8745      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8746      &  ggg1(3),ggg2(3)
8747       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8748      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8749 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8750 C           the respective energy moment and not to the cluster cumulant.
8751       s1=0.0d0
8752       s8=0.0d0
8753       s13=0.0d0
8754 c
8755       eello_turn6=0.0d0
8756       j=i+4
8757       k=i+1
8758       l=i+3
8759       iti=itortyp(itype(i))
8760       itk=itortyp(itype(k))
8761       itk1=itortyp(itype(k+1))
8762       itl=itortyp(itype(l))
8763       itj=itortyp(itype(j))
8764 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8765 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8766 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8767 cd        eello6=0.0d0
8768 cd        return
8769 cd      endif
8770 cd      write (iout,*)
8771 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8772 cd     &   ' and',k,l
8773 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8774       do iii=1,2
8775         do kkk=1,5
8776           do lll=1,3
8777             derx_turn(lll,kkk,iii)=0.0d0
8778           enddo
8779         enddo
8780       enddo
8781 cd      eij=1.0d0
8782 cd      ekl=1.0d0
8783 cd      ekont=1.0d0
8784       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8785 cd      eello6_5=0.0d0
8786 cd      write (2,*) 'eello6_5',eello6_5
8787 #ifdef MOMENT
8788       call transpose2(AEA(1,1,1),auxmat(1,1))
8789       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8790       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8791       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8792 #endif
8793       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8794       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8795       s2 = scalar2(b1(1,itk),vtemp1(1))
8796 #ifdef MOMENT
8797       call transpose2(AEA(1,1,2),atemp(1,1))
8798       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8799       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8800       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8801 #endif
8802       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8803       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8804       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8805 #ifdef MOMENT
8806       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8807       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8808       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8809       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8810       ss13 = scalar2(b1(1,itk),vtemp4(1))
8811       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8812 #endif
8813 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8814 c      s1=0.0d0
8815 c      s2=0.0d0
8816 c      s8=0.0d0
8817 c      s12=0.0d0
8818 c      s13=0.0d0
8819       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8820 C Derivatives in gamma(i+2)
8821       s1d =0.0d0
8822       s8d =0.0d0
8823 #ifdef MOMENT
8824       call transpose2(AEA(1,1,1),auxmatd(1,1))
8825       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8826       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8827       call transpose2(AEAderg(1,1,2),atempd(1,1))
8828       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8829       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8830 #endif
8831       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8832       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8833       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8834 c      s1d=0.0d0
8835 c      s2d=0.0d0
8836 c      s8d=0.0d0
8837 c      s12d=0.0d0
8838 c      s13d=0.0d0
8839       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8840 C Derivatives in gamma(i+3)
8841 #ifdef MOMENT
8842       call transpose2(AEA(1,1,1),auxmatd(1,1))
8843       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8844       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8845       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8846 #endif
8847       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8848       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8849       s2d = scalar2(b1(1,itk),vtemp1d(1))
8850 #ifdef MOMENT
8851       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8852       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8853 #endif
8854       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8855 #ifdef MOMENT
8856       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8857       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8858       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8859 #endif
8860 c      s1d=0.0d0
8861 c      s2d=0.0d0
8862 c      s8d=0.0d0
8863 c      s12d=0.0d0
8864 c      s13d=0.0d0
8865 #ifdef MOMENT
8866       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8867      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8868 #else
8869       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8870      &               -0.5d0*ekont*(s2d+s12d)
8871 #endif
8872 C Derivatives in gamma(i+4)
8873       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8874       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8875       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8876 #ifdef MOMENT
8877       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8878       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8879       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8880 #endif
8881 c      s1d=0.0d0
8882 c      s2d=0.0d0
8883 c      s8d=0.0d0
8884 C      s12d=0.0d0
8885 c      s13d=0.0d0
8886 #ifdef MOMENT
8887       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8888 #else
8889       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8890 #endif
8891 C Derivatives in gamma(i+5)
8892 #ifdef MOMENT
8893       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8894       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8895       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8896 #endif
8897       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8898       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8899       s2d = scalar2(b1(1,itk),vtemp1d(1))
8900 #ifdef MOMENT
8901       call transpose2(AEA(1,1,2),atempd(1,1))
8902       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8903       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8904 #endif
8905       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8906       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8907 #ifdef MOMENT
8908       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8909       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8910       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8911 #endif
8912 c      s1d=0.0d0
8913 c      s2d=0.0d0
8914 c      s8d=0.0d0
8915 c      s12d=0.0d0
8916 c      s13d=0.0d0
8917 #ifdef MOMENT
8918       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8919      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8920 #else
8921       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8922      &               -0.5d0*ekont*(s2d+s12d)
8923 #endif
8924 C Cartesian derivatives
8925       do iii=1,2
8926         do kkk=1,5
8927           do lll=1,3
8928 #ifdef MOMENT
8929             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8930             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8931             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8932 #endif
8933             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8934             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8935      &          vtemp1d(1))
8936             s2d = scalar2(b1(1,itk),vtemp1d(1))
8937 #ifdef MOMENT
8938             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8939             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8940             s8d = -(atempd(1,1)+atempd(2,2))*
8941      &           scalar2(cc(1,1,itl),vtemp2(1))
8942 #endif
8943             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8944      &           auxmatd(1,1))
8945             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8946             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8947 c      s1d=0.0d0
8948 c      s2d=0.0d0
8949 c      s8d=0.0d0
8950 c      s12d=0.0d0
8951 c      s13d=0.0d0
8952 #ifdef MOMENT
8953             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8954      &        - 0.5d0*(s1d+s2d)
8955 #else
8956             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8957      &        - 0.5d0*s2d
8958 #endif
8959 #ifdef MOMENT
8960             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8961      &        - 0.5d0*(s8d+s12d)
8962 #else
8963             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8964      &        - 0.5d0*s12d
8965 #endif
8966           enddo
8967         enddo
8968       enddo
8969 #ifdef MOMENT
8970       do kkk=1,5
8971         do lll=1,3
8972           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8973      &      achuj_tempd(1,1))
8974           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8975           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8976           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8977           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8978           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8979      &      vtemp4d(1))
8980           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8981           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8982           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8983         enddo
8984       enddo
8985 #endif
8986 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8987 cd     &  16*eel_turn6_num
8988 cd      goto 1112
8989       if (j.lt.nres-1) then
8990         j1=j+1
8991         j2=j-1
8992       else
8993         j1=j-1
8994         j2=j-2
8995       endif
8996       if (l.lt.nres-1) then
8997         l1=l+1
8998         l2=l-1
8999       else
9000         l1=l-1
9001         l2=l-2
9002       endif
9003       do ll=1,3
9004 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9005 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9006 cgrad        ghalf=0.5d0*ggg1(ll)
9007 cd        ghalf=0.0d0
9008         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9009         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9010         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9011      &    +ekont*derx_turn(ll,2,1)
9012         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9013         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9014      &    +ekont*derx_turn(ll,4,1)
9015         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9016         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9017         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9018 cgrad        ghalf=0.5d0*ggg2(ll)
9019 cd        ghalf=0.0d0
9020         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9021      &    +ekont*derx_turn(ll,2,2)
9022         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9023         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9024      &    +ekont*derx_turn(ll,4,2)
9025         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9026         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9027         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9028       enddo
9029 cd      goto 1112
9030 cgrad      do m=i+1,j-1
9031 cgrad        do ll=1,3
9032 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9033 cgrad        enddo
9034 cgrad      enddo
9035 cgrad      do m=k+1,l-1
9036 cgrad        do ll=1,3
9037 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9038 cgrad        enddo
9039 cgrad      enddo
9040 cgrad1112  continue
9041 cgrad      do m=i+2,j2
9042 cgrad        do ll=1,3
9043 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9044 cgrad        enddo
9045 cgrad      enddo
9046 cgrad      do m=k+2,l2
9047 cgrad        do ll=1,3
9048 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9049 cgrad        enddo
9050 cgrad      enddo
9051 cd      do iii=1,nres-3
9052 cd        write (2,*) iii,g_corr6_loc(iii)
9053 cd      enddo
9054       eello_turn6=ekont*eel_turn6
9055 cd      write (2,*) 'ekont',ekont
9056 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9057       return
9058       end
9059
9060 C-----------------------------------------------------------------------------
9061       double precision function scalar(u,v)
9062 !DIR$ INLINEALWAYS scalar
9063 #ifndef OSF
9064 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9065 #endif
9066       implicit none
9067       double precision u(3),v(3)
9068 cd      double precision sc
9069 cd      integer i
9070 cd      sc=0.0d0
9071 cd      do i=1,3
9072 cd        sc=sc+u(i)*v(i)
9073 cd      enddo
9074 cd      scalar=sc
9075
9076       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9077       return
9078       end
9079 crc-------------------------------------------------
9080       SUBROUTINE MATVEC2(A1,V1,V2)
9081 !DIR$ INLINEALWAYS MATVEC2
9082 #ifndef OSF
9083 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9084 #endif
9085       implicit real*8 (a-h,o-z)
9086       include 'DIMENSIONS'
9087       DIMENSION A1(2,2),V1(2),V2(2)
9088 c      DO 1 I=1,2
9089 c        VI=0.0
9090 c        DO 3 K=1,2
9091 c    3     VI=VI+A1(I,K)*V1(K)
9092 c        Vaux(I)=VI
9093 c    1 CONTINUE
9094
9095       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9096       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9097
9098       v2(1)=vaux1
9099       v2(2)=vaux2
9100       END
9101 C---------------------------------------
9102       SUBROUTINE MATMAT2(A1,A2,A3)
9103 #ifndef OSF
9104 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9105 #endif
9106       implicit real*8 (a-h,o-z)
9107       include 'DIMENSIONS'
9108       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9109 c      DIMENSION AI3(2,2)
9110 c        DO  J=1,2
9111 c          A3IJ=0.0
9112 c          DO K=1,2
9113 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9114 c          enddo
9115 c          A3(I,J)=A3IJ
9116 c       enddo
9117 c      enddo
9118
9119       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9120       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9121       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9122       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9123
9124       A3(1,1)=AI3_11
9125       A3(2,1)=AI3_21
9126       A3(1,2)=AI3_12
9127       A3(2,2)=AI3_22
9128       END
9129
9130 c-------------------------------------------------------------------------
9131       double precision function scalar2(u,v)
9132 !DIR$ INLINEALWAYS scalar2
9133       implicit none
9134       double precision u(2),v(2)
9135       double precision sc
9136       integer i
9137       scalar2=u(1)*v(1)+u(2)*v(2)
9138       return
9139       end
9140
9141 C-----------------------------------------------------------------------------
9142
9143       subroutine transpose2(a,at)
9144 !DIR$ INLINEALWAYS transpose2
9145 #ifndef OSF
9146 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9147 #endif
9148       implicit none
9149       double precision a(2,2),at(2,2)
9150       at(1,1)=a(1,1)
9151       at(1,2)=a(2,1)
9152       at(2,1)=a(1,2)
9153       at(2,2)=a(2,2)
9154       return
9155       end
9156 c--------------------------------------------------------------------------
9157       subroutine transpose(n,a,at)
9158       implicit none
9159       integer n,i,j
9160       double precision a(n,n),at(n,n)
9161       do i=1,n
9162         do j=1,n
9163           at(j,i)=a(i,j)
9164         enddo
9165       enddo
9166       return
9167       end
9168 C---------------------------------------------------------------------------
9169       subroutine prodmat3(a1,a2,kk,transp,prod)
9170 !DIR$ INLINEALWAYS prodmat3
9171 #ifndef OSF
9172 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9173 #endif
9174       implicit none
9175       integer i,j
9176       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9177       logical transp
9178 crc      double precision auxmat(2,2),prod_(2,2)
9179
9180       if (transp) then
9181 crc        call transpose2(kk(1,1),auxmat(1,1))
9182 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9183 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9184
9185            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9186      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9187            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9188      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9189            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9190      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9191            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9192      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9193
9194       else
9195 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9196 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9197
9198            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9199      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9200            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9201      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9202            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9203      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9204            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9205      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9206
9207       endif
9208 c      call transpose2(a2(1,1),a2t(1,1))
9209
9210 crc      print *,transp
9211 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9212 crc      print *,((prod(i,j),i=1,2),j=1,2)
9213
9214       return
9215       end
9216