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 c      print *,"Processor",myrank," computed USCSC"
 135 #ifdef TIMING
 136 #ifdef MPI
 137       time01=MPI_Wtime()
 138 #else
 139       time00=tcpu()
 140 #endif
 141 #endif
 142       call vec_and_deriv
 143 #ifdef TIMING
 144 #ifdef MPI
 145       time_vec=time_vec+MPI_Wtime()-time01
 146 #else
 147       time_vec=time_vec+tcpu()-time01
 148 #endif
 149 #endif
 150 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 151       if (ipot.lt.6) then
 152 #ifdef SPLITELE
 153          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 154      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 155      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 156      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 157 #else
 158          if (welec.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 #endif
 163             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 164          else
 165             ees=0.0d0
 166             evdw1=0.0d0
 167             eel_loc=0.0d0
 168             eello_turn3=0.0d0
 169             eello_turn4=0.0d0
 170          endif
 171       else
 172 c        write (iout,*) "Soft-spheer ELEC potential"
 173         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 174      &   eello_turn4)
 175       endif
 176 c      print *,"Processor",myrank," computed UELEC"
 177 C
 178 C Calculate excluded-volume interaction energy between peptide groups
 179 C and side chains.
 180 C
 181       if (ipot.lt.6) then
 182        if(wscp.gt.0d0) then
 183         call escp(evdw2,evdw2_14)
 184        else
 185         evdw2=0
 186         evdw2_14=0
 187        endif
 188       else
 189 c        write (iout,*) "Soft-sphere SCP potential"
 190         call escp_soft_sphere(evdw2,evdw2_14)
 191       endif
 192 c
 193 c Calculate the bond-stretching energy
 194 c
 195       call ebond(estr)
 196 C
 197 C Calculate the disulfide-bridge and other energy and the contributions
 198 C from other distance constraints.
 199 cd    print *,'Calling EHPB'
 200       call edis(ehpb)
 201 cd    print *,'EHPB exitted succesfully.'
 202 C
 203 C Calculate the virtual-bond-angle energy.
 204 C
 205       if (wang.gt.0d0) then
 206         call ebend(ebe)
 207       else
 208         ebe=0
 209       endif
 210 c      print *,"Processor",myrank," computed UB"
 211 C
 212 C Calculate the SC local energy.
 213 C
 214       call esc(escloc)
 215 c      print *,"Processor",myrank," computed USC"
 216 C
 217 C Calculate the virtual-bond torsional energy.
 218 C
 219 cd    print *,'nterm=',nterm
 220       if (wtor.gt.0) then
 221        call etor(etors,edihcnstr)
 222       else
 223        etors=0
 224        edihcnstr=0
 225       endif
 226 c      print *,"Processor",myrank," computed Utor"
 227 C
 228 C 6/23/01 Calculate double-torsional energy
 229 C
 230       if (wtor_d.gt.0) then
 231        call etor_d(etors_d)
 232       else
 233        etors_d=0
 234       endif
 235 c      print *,"Processor",myrank," computed Utord"
 236 C
 237 C 21/5/07 Calculate local sicdechain correlation energy
 238 C
 239       if (wsccor.gt.0.0d0) then
 240         call eback_sc_corr(esccor)
 241       else
 242         esccor=0.0d0
 243       endif
 244 c      print *,"Processor",myrank," computed Usccorr"
 245 C
 246 C 12/1/95 Multi-body terms
 247 C
 248       n_corr=0
 249       n_corr1=0
 250       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 251      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 252          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 253 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 254 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 255       else
 256          ecorr=0.0d0
 257          ecorr5=0.0d0
 258          ecorr6=0.0d0
 259          eturn6=0.0d0
 260       endif
 261       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 262          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 263 cd         write (iout,*) "multibody_hb ecorr",ecorr
 264       endif
 265 c      print *,"Processor",myrank," computed Ucorr"
 266 C
 267 C If performing constraint dynamics, call the constraint energy
 268 C  after the equilibration time
 269       if(usampl.and.totT.gt.eq_time) then
 270          call EconstrQ
 271          call Econstr_back
 272       else
 273          Uconst=0.0d0
 274          Uconst_back=0.0d0
 275       endif
 276 #ifdef TIMING
 277 #ifdef MPI
 278       time_enecalc=time_enecalc+MPI_Wtime()-time00
 279 #else
 280       time_enecalc=time_enecalc+tcpu()-time00
 281 #endif
 282 #endif
 283 c      print *,"Processor",myrank," computed Uconstr"
 284 #ifdef TIMING
 285 #ifdef MPI
 286       time00=MPI_Wtime()
 287 #else
 288       time00=tcpu()
 289 #endif
 290 #endif
 291 c
 292 C Sum the energies
 293 C
 294       energia(1)=evdw
 295 #ifdef SCP14
 296       energia(2)=evdw2-evdw2_14
 297       energia(18)=evdw2_14
 298 #else
 299       energia(2)=evdw2
 300       energia(18)=0.0d0
 301 #endif
 302 #ifdef SPLITELE
 303       energia(3)=ees
 304       energia(16)=evdw1
 305 #else
 306       energia(3)=ees+evdw1
 307       energia(16)=0.0d0
 308 #endif
 309       energia(4)=ecorr
 310       energia(5)=ecorr5
 311       energia(6)=ecorr6
 312       energia(7)=eel_loc
 313       energia(8)=eello_turn3
 314       energia(9)=eello_turn4
 315       energia(10)=eturn6
 316       energia(11)=ebe
 317       energia(12)=escloc
 318       energia(13)=etors
 319       energia(14)=etors_d
 320       energia(15)=ehpb
 321       energia(19)=edihcnstr
 322       energia(17)=estr
 323       energia(20)=Uconst+Uconst_back
 324       energia(21)=esccor
 325       energia(22)=evdw_p
 326       energia(23)=evdw_m
 327 c      print *," Processor",myrank," calls SUM_ENERGY"
 328       call sum_energy(energia,.true.)
 329 c      print *," Processor",myrank," left SUM_ENERGY"
 330 #ifdef TIMING
 331 #ifdef MPI
 332       time_sumene=time_sumene+MPI_Wtime()-time00
 333 #else
 334       time_sumene=time_sumene+tcpu()-time00
 335 #endif
 336 #endif
 337       return
 338       end
 339 c-------------------------------------------------------------------------------
 340       subroutine sum_energy(energia,reduce)
 341       implicit real*8 (a-h,o-z)
 342       include 'DIMENSIONS'
 343 #ifndef ISNAN
 344       external proc_proc
 345 #ifdef WINPGI
 346 cMS$ATTRIBUTES C ::  proc_proc
 347 #endif
 348 #endif
 349 #ifdef MPI
 350       include "mpif.h"
 351 #endif
 352       include 'COMMON.SETUP'
 353       include 'COMMON.IOUNITS'
 354       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 355       include 'COMMON.FFIELD'
 356       include 'COMMON.DERIV'
 357       include 'COMMON.INTERACT'
 358       include 'COMMON.SBRIDGE'
 359       include 'COMMON.CHAIN'
 360       include 'COMMON.VAR'
 361       include 'COMMON.CONTROL'
 362       include 'COMMON.TIME1'
 363       logical reduce
 364 #ifdef MPI
 365       if (nfgtasks.gt.1 .and. reduce) then
 366 #ifdef DEBUG
 367         write (iout,*) "energies before REDUCE"
 368         call enerprint(energia)
 369         call flush(iout)
 370 #endif
 371         do i=0,n_ene
 372           enebuff(i)=energia(i)
 373         enddo
 374         time00=MPI_Wtime()
 375         call MPI_Barrier(FG_COMM,IERR)
 376         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 377         time00=MPI_Wtime()
 378         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 379      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 380 #ifdef DEBUG
 381         write (iout,*) "energies after REDUCE"
 382         call enerprint(energia)
 383         call flush(iout)
 384 #endif
 385         time_Reduce=time_Reduce+MPI_Wtime()-time00
 386       endif
 387       if (fg_rank.eq.0) then
 388 #endif
 389 #ifdef TSCSC
 390       evdw=energia(22)+wsct*energia(23)
 391 #else
 392       evdw=energia(1)
 393 #endif
 394 #ifdef SCP14
 395       evdw2=energia(2)+energia(18)
 396       evdw2_14=energia(18)
 397 #else
 398       evdw2=energia(2)
 399 #endif
 400 #ifdef SPLITELE
 401       ees=energia(3)
 402       evdw1=energia(16)
 403 #else
 404       ees=energia(3)
 405       evdw1=0.0d0
 406 #endif
 407       ecorr=energia(4)
 408       ecorr5=energia(5)
 409       ecorr6=energia(6)
 410       eel_loc=energia(7)
 411       eello_turn3=energia(8)
 412       eello_turn4=energia(9)
 413       eturn6=energia(10)
 414       ebe=energia(11)
 415       escloc=energia(12)
 416       etors=energia(13)
 417       etors_d=energia(14)
 418       ehpb=energia(15)
 419       edihcnstr=energia(19)
 420       estr=energia(17)
 421       Uconst=energia(20)
 422       esccor=energia(21)
 423 #ifdef SPLITELE
 424       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 425      & +wang*ebe+wtor*etors+wscloc*escloc
 426      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 427      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 428      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 429      & +wbond*estr+Uconst+wsccor*esccor
 430 #else
 431       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 432      & +wang*ebe+wtor*etors+wscloc*escloc
 433      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 434      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 435      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 436      & +wbond*estr+Uconst+wsccor*esccor
 437 #endif
 438       energia(0)=etot
 439 c detecting NaNQ
 440 #ifdef ISNAN
 441 #ifdef AIX
 442       if (isnan(etot).ne.0) energia(0)=1.0d+99
 443 #else
 444       if (isnan(etot)) energia(0)=1.0d+99
 445 #endif
 446 #else
 447       i=0
 448 #ifdef WINPGI
 449       idumm=proc_proc(etot,i)
 450 #else
 451       call proc_proc(etot,i)
 452 #endif
 453       if(i.eq.1)energia(0)=1.0d+99
 454 #endif
 455 #ifdef MPI
 456       endif
 457 #endif
 458       return
 459       end
 460 c-------------------------------------------------------------------------------
 461       subroutine sum_gradient
 462       implicit real*8 (a-h,o-z)
 463       include 'DIMENSIONS'
 464 #ifndef ISNAN
 465       external proc_proc
 466 #ifdef WINPGI
 467 cMS$ATTRIBUTES C ::  proc_proc
 468 #endif
 469 #endif
 470 #ifdef MPI
 471       include 'mpif.h'
 472 #endif
 473       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 474      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 475       include 'COMMON.SETUP'
 476       include 'COMMON.IOUNITS'
 477       include 'COMMON.FFIELD'
 478       include 'COMMON.DERIV'
 479       include 'COMMON.INTERACT'
 480       include 'COMMON.SBRIDGE'
 481       include 'COMMON.CHAIN'
 482       include 'COMMON.VAR'
 483       include 'COMMON.CONTROL'
 484       include 'COMMON.TIME1'
 485       include 'COMMON.MAXGRAD'
 486 #ifdef TIMING
 487 #ifdef MPI
 488       time01=MPI_Wtime()
 489 #else
 490       time01=tcpu()
 491 #endif
 492 #endif
 493 #ifdef DEBUG
 494       write (iout,*) "sum_gradient gvdwc, gvdwx"
 495       do i=1,nres
 496         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 497      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 498      &   (gvdwcT(j,i),j=1,3)
 499       enddo
 500       call flush(iout)
 501 #endif
 502 #ifdef MPI
 503 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 504         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 505      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 506 #endif
 507 C
 508 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 509 C            in virtual-bond-vector coordinates
 510 C
 511 #ifdef DEBUG
 512 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 513 c      do i=1,nres-1
 514 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 515 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 516 c      enddo
 517 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 518 c      do i=1,nres-1
 519 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 520 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 521 c      enddo
 522       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 523       do i=1,nres
 524         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 525      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 526      &   g_corr5_loc(i)
 527       enddo
 528       call flush(iout)
 529 #endif
 530 #ifdef SPLITELE
 531 #ifdef TSCSC
 532       do i=1,nct
 533         do j=1,3
 534           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 535      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 536      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 537      &                wel_loc*gel_loc_long(j,i)+
 538      &                wcorr*gradcorr_long(j,i)+
 539      &                wcorr5*gradcorr5_long(j,i)+
 540      &                wcorr6*gradcorr6_long(j,i)+
 541      &                wturn6*gcorr6_turn_long(j,i)+
 542      &                wstrain*ghpbc(j,i)
 543         enddo
 544       enddo
 545 #else
 546       do i=1,nct
 547         do j=1,3
 548           gradbufc(j,i)=wsc*gvdwc(j,i)+
 549      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 550      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 551      &                wel_loc*gel_loc_long(j,i)+
 552      &                wcorr*gradcorr_long(j,i)+
 553      &                wcorr5*gradcorr5_long(j,i)+
 554      &                wcorr6*gradcorr6_long(j,i)+
 555      &                wturn6*gcorr6_turn_long(j,i)+
 556      &                wstrain*ghpbc(j,i)
 557         enddo
 558       enddo
 559 #endif
 560 #else
 561       do i=1,nct
 562         do j=1,3
 563           gradbufc(j,i)=wsc*gvdwc(j,i)+
 564      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 565      &                welec*gelc_long(j,i)+
 566      &                wbond*gradb(j,i)+
 567      &                wel_loc*gel_loc_long(j,i)+
 568      &                wcorr*gradcorr_long(j,i)+
 569      &                wcorr5*gradcorr5_long(j,i)+
 570      &                wcorr6*gradcorr6_long(j,i)+
 571      &                wturn6*gcorr6_turn_long(j,i)+
 572      &                wstrain*ghpbc(j,i)
 573         enddo
 574       enddo
 575 #endif
 576 #ifdef MPI
 577       if (nfgtasks.gt.1) then
 578       time00=MPI_Wtime()
 579 #ifdef DEBUG
 580       write (iout,*) "gradbufc before allreduce"
 581       do i=1,nres
 582         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 583       enddo
 584       call flush(iout)
 585 #endif
 586       do i=1,nres
 587         do j=1,3
 588           gradbufc_sum(j,i)=gradbufc(j,i)
 589         enddo
 590       enddo
 591 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 592 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 593 c      time_reduce=time_reduce+MPI_Wtime()-time00
 594 #ifdef DEBUG
 595 c      write (iout,*) "gradbufc_sum after allreduce"
 596 c      do i=1,nres
 597 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 598 c      enddo
 599 c      call flush(iout)
 600 #endif
 601 #ifdef TIMING
 602 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 603 #endif
 604       do i=nnt,nres
 605         do k=1,3
 606           gradbufc(k,i)=0.0d0
 607         enddo
 608       enddo
 609 #ifdef DEBUG
 610       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 611       write (iout,*) (i," jgrad_start",jgrad_start(i),
 612      &                  " jgrad_end  ",jgrad_end(i),
 613      &                  i=igrad_start,igrad_end)
 614 #endif
 615 c
 616 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 617 c do not parallelize this part.
 618 c
 619 c      do i=igrad_start,igrad_end
 620 c        do j=jgrad_start(i),jgrad_end(i)
 621 c          do k=1,3
 622 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 623 c          enddo
 624 c        enddo
 625 c      enddo
 626       do j=1,3
 627         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 628       enddo
 629       do i=nres-2,nnt,-1
 630         do j=1,3
 631           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 632         enddo
 633       enddo
 634 #ifdef DEBUG
 635       write (iout,*) "gradbufc after summing"
 636       do i=1,nres
 637         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 638       enddo
 639       call flush(iout)
 640 #endif
 641       else
 642 #endif
 643 #ifdef DEBUG
 644       write (iout,*) "gradbufc"
 645       do i=1,nres
 646         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 647       enddo
 648       call flush(iout)
 649 #endif
 650       do i=1,nres
 651         do j=1,3
 652           gradbufc_sum(j,i)=gradbufc(j,i)
 653           gradbufc(j,i)=0.0d0
 654         enddo
 655       enddo
 656       do j=1,3
 657         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 658       enddo
 659       do i=nres-2,nnt,-1
 660         do j=1,3
 661           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 662         enddo
 663       enddo
 664 c      do i=nnt,nres-1
 665 c        do k=1,3
 666 c          gradbufc(k,i)=0.0d0
 667 c        enddo
 668 c        do j=i+1,nres
 669 c          do k=1,3
 670 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 671 c          enddo
 672 c        enddo
 673 c      enddo
 674 #ifdef DEBUG
 675       write (iout,*) "gradbufc after summing"
 676       do i=1,nres
 677         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 678       enddo
 679       call flush(iout)
 680 #endif
 681 #ifdef MPI
 682       endif
 683 #endif
 684       do k=1,3
 685         gradbufc(k,nres)=0.0d0
 686       enddo
 687       do i=1,nct
 688         do j=1,3
 689 #ifdef SPLITELE
 690           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 691      &                wel_loc*gel_loc(j,i)+
 692      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 693      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 694      &                wel_loc*gel_loc_long(j,i)+
 695      &                wcorr*gradcorr_long(j,i)+
 696      &                wcorr5*gradcorr5_long(j,i)+
 697      &                wcorr6*gradcorr6_long(j,i)+
 698      &                wturn6*gcorr6_turn_long(j,i))+
 699      &                wbond*gradb(j,i)+
 700      &                wcorr*gradcorr(j,i)+
 701      &                wturn3*gcorr3_turn(j,i)+
 702      &                wturn4*gcorr4_turn(j,i)+
 703      &                wcorr5*gradcorr5(j,i)+
 704      &                wcorr6*gradcorr6(j,i)+
 705      &                wturn6*gcorr6_turn(j,i)+
 706      &                wsccor*gsccorc(j,i)
 707      &               +wscloc*gscloc(j,i)
 708 #else
 709           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 710      &                wel_loc*gel_loc(j,i)+
 711      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 712      &                welec*gelc_long(j,i)+
 713      &                wel_loc*gel_loc_long(j,i)+
 714      &                wcorr*gcorr_long(j,i)+
 715      &                wcorr5*gradcorr5_long(j,i)+
 716      &                wcorr6*gradcorr6_long(j,i)+
 717      &                wturn6*gcorr6_turn_long(j,i))+
 718      &                wbond*gradb(j,i)+
 719      &                wcorr*gradcorr(j,i)+
 720      &                wturn3*gcorr3_turn(j,i)+
 721      &                wturn4*gcorr4_turn(j,i)+
 722      &                wcorr5*gradcorr5(j,i)+
 723      &                wcorr6*gradcorr6(j,i)+
 724      &                wturn6*gcorr6_turn(j,i)+
 725      &                wsccor*gsccorc(j,i)
 726      &               +wscloc*gscloc(j,i)
 727 #endif
 728 #ifdef TSCSC
 729           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 730      &                  wscp*gradx_scp(j,i)+
 731      &                  wbond*gradbx(j,i)+
 732      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 733      &                  wsccor*gsccorx(j,i)
 734      &                 +wscloc*gsclocx(j,i)
 735 #else
 736           gradx(j,i,icg)=wsc*gvdwx(j,i)+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 #endif
 742         enddo
 743       enddo
 744 #ifdef DEBUG
 745       write (iout,*) "gloc before adding corr"
 746       do i=1,4*nres
 747         write (iout,*) i,gloc(i,icg)
 748       enddo
 749 #endif
 750       do i=1,nres-3
 751         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 752      &   +wcorr5*g_corr5_loc(i)
 753      &   +wcorr6*g_corr6_loc(i)
 754      &   +wturn4*gel_loc_turn4(i)
 755      &   +wturn3*gel_loc_turn3(i)
 756      &   +wturn6*gel_loc_turn6(i)
 757      &   +wel_loc*gel_loc_loc(i)
 758      &   +wsccor*gsccor_loc(i)
 759       enddo
 760 #ifdef DEBUG
 761       write (iout,*) "gloc after adding corr"
 762       do i=1,4*nres
 763         write (iout,*) i,gloc(i,icg)
 764       enddo
 765 #endif
 766 #ifdef MPI
 767       if (nfgtasks.gt.1) then
 768         do j=1,3
 769           do i=1,nres
 770             gradbufc(j,i)=gradc(j,i,icg)
 771             gradbufx(j,i)=gradx(j,i,icg)
 772           enddo
 773         enddo
 774         do i=1,4*nres
 775           glocbuf(i)=gloc(i,icg)
 776         enddo
 777         time00=MPI_Wtime()
 778         call MPI_Barrier(FG_COMM,IERR)
 779         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 780         time00=MPI_Wtime()
 781         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 782      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 783         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 784      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 785         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 786      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 787         time_reduce=time_reduce+MPI_Wtime()-time00
 788 #ifdef DEBUG
 789       write (iout,*) "gloc after reduce"
 790       do i=1,4*nres
 791         write (iout,*) i,gloc(i,icg)
 792       enddo
 793 #endif
 794       endif
 795 #endif
 796       if (gnorm_check) then
 797 c
 798 c Compute the maximum elements of the gradient
 799 c
 800       gvdwc_max=0.0d0
 801       gvdwc_scp_max=0.0d0
 802       gelc_max=0.0d0
 803       gvdwpp_max=0.0d0
 804       gradb_max=0.0d0
 805       ghpbc_max=0.0d0
 806       gradcorr_max=0.0d0
 807       gel_loc_max=0.0d0
 808       gcorr3_turn_max=0.0d0
 809       gcorr4_turn_max=0.0d0
 810       gradcorr5_max=0.0d0
 811       gradcorr6_max=0.0d0
 812       gcorr6_turn_max=0.0d0
 813       gsccorc_max=0.0d0
 814       gscloc_max=0.0d0
 815       gvdwx_max=0.0d0
 816       gradx_scp_max=0.0d0
 817       ghpbx_max=0.0d0
 818       gradxorr_max=0.0d0
 819       gsccorx_max=0.0d0
 820       gsclocx_max=0.0d0
 821       do i=1,nct
 822         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 823         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 824 #ifdef TSCSC
 825         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 826         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 827 #endif
 828         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 829         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 830      &   gvdwc_scp_max=gvdwc_scp_norm
 831         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 832         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 833         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 834         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 835         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 836         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 837         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 838         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 839         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 840         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 841         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 842         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 843         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 844      &    gcorr3_turn(1,i)))
 845         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 846      &    gcorr3_turn_max=gcorr3_turn_norm
 847         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 848      &    gcorr4_turn(1,i)))
 849         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 850      &    gcorr4_turn_max=gcorr4_turn_norm
 851         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 852         if (gradcorr5_norm.gt.gradcorr5_max)
 853      &    gradcorr5_max=gradcorr5_norm
 854         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 855         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 856         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 857      &    gcorr6_turn(1,i)))
 858         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 859      &    gcorr6_turn_max=gcorr6_turn_norm
 860         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 861         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 862         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 863         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 864         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 865         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 866 #ifdef TSCSC
 867         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 868         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 869 #endif
 870         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 871         if (gradx_scp_norm.gt.gradx_scp_max)
 872      &    gradx_scp_max=gradx_scp_norm
 873         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 874         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 875         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 876         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 877         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 878         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 879         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 880         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 881       enddo
 882       if (gradout) then
 883 #ifdef AIX
 884         open(istat,file=statname,position="append")
 885 #else
 886         open(istat,file=statname,access="append")
 887 #endif
 888         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 889      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 890      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 891      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 892      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 893      &     gsccorx_max,gsclocx_max
 894         close(istat)
 895         if (gvdwc_max.gt.1.0d4) then
 896           write (iout,*) "gvdwc gvdwx gradb gradbx"
 897           do i=nnt,nct
 898             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 899      &        gradb(j,i),gradbx(j,i),j=1,3)
 900           enddo
 901           call pdbout(0.0d0,'cipiszcze',iout)
 902           call flush(iout)
 903         endif
 904       endif
 905       endif
 906 #ifdef DEBUG
 907       write (iout,*) "gradc gradx gloc"
 908       do i=1,nres
 909         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 910      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 911       enddo
 912 #endif
 913 #ifdef TIMING
 914 #ifdef MPI
 915       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 916 #else
 917       time_sumgradient=time_sumgradient+tcpu()-time01
 918 #endif
 919 #endif
 920       return
 921       end
 922 c-------------------------------------------------------------------------------
 923       subroutine rescale_weights(t_bath)
 924       implicit real*8 (a-h,o-z)
 925       include 'DIMENSIONS'
 926       include 'COMMON.IOUNITS'
 927       include 'COMMON.FFIELD'
 928       include 'COMMON.SBRIDGE'
 929       double precision kfac /2.4d0/
 930       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 931 c      facT=temp0/t_bath
 932 c      facT=2*temp0/(t_bath+temp0)
 933       if (rescale_mode.eq.0) then
 934         facT=1.0d0
 935         facT2=1.0d0
 936         facT3=1.0d0
 937         facT4=1.0d0
 938         facT5=1.0d0
 939       else if (rescale_mode.eq.1) then
 940         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 941         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 942         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 943         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 944         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 945       else if (rescale_mode.eq.2) then
 946         x=t_bath/temp0
 947         x2=x*x
 948         x3=x2*x
 949         x4=x3*x
 950         x5=x4*x
 951         facT=licznik/dlog(dexp(x)+dexp(-x))
 952         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 953         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 954         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 955         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 956       else
 957         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 958         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 959 #ifdef MPI
 960        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 961 #endif
 962        stop 555
 963       endif
 964       welec=weights(3)*fact
 965       wcorr=weights(4)*fact3
 966       wcorr5=weights(5)*fact4
 967       wcorr6=weights(6)*fact5
 968       wel_loc=weights(7)*fact2
 969       wturn3=weights(8)*fact2
 970       wturn4=weights(9)*fact3
 971       wturn6=weights(10)*fact5
 972       wtor=weights(13)*fact
 973       wtor_d=weights(14)*fact2
 974       wsccor=weights(21)*fact
 975 #ifdef TSCSC
 976 c      wsct=t_bath/temp0
 977       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 978 #endif
 979       return
 980       end
 981 C------------------------------------------------------------------------
 982       subroutine enerprint(energia)
 983       implicit real*8 (a-h,o-z)
 984       include 'DIMENSIONS'
 985       include 'COMMON.IOUNITS'
 986       include 'COMMON.FFIELD'
 987       include 'COMMON.SBRIDGE'
 988       include 'COMMON.MD'
 989       double precision energia(0:n_ene)
 990       etot=energia(0)
 991 #ifdef TSCSC
 992       evdw=energia(22)+wsct*energia(23)
 993 #else
 994       evdw=energia(1)
 995 #endif
 996       evdw2=energia(2)
 997 #ifdef SCP14
 998       evdw2=energia(2)+energia(18)
 999 #else
1000       evdw2=energia(2)
1001 #endif
1002       ees=energia(3)
1003 #ifdef SPLITELE
1004       evdw1=energia(16)
1005 #endif
1006       ecorr=energia(4)
1007       ecorr5=energia(5)
1008       ecorr6=energia(6)
1009       eel_loc=energia(7)
1010       eello_turn3=energia(8)
1011       eello_turn4=energia(9)
1012       eello_turn6=energia(10)
1013       ebe=energia(11)
1014       escloc=energia(12)
1015       etors=energia(13)
1016       etors_d=energia(14)
1017       ehpb=energia(15)
1018       edihcnstr=energia(19)
1019       estr=energia(17)
1020       Uconst=energia(20)
1021       esccor=energia(21)
1022 #ifdef SPLITELE
1023       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1024      &  estr,wbond,ebe,wang,
1025      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1026      &  ecorr,wcorr,
1027      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1028      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1029      &  edihcnstr,ebr*nss,
1030      &  Uconst,etot
1031    10 format (/'Virtual-chain energies:'//
1032      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1033      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1034      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1035      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1036      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1037      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1038      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1039      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1040      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1041      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1042      & ' (SS bridges & dist. cnstr.)'/
1043      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1044      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1045      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1046      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1047      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1048      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1049      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1050      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1051      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1052      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1053      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1054      & 'ETOT=  ',1pE16.6,' (total)')
1055 #else
1056       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1057      &  estr,wbond,ebe,wang,
1058      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1059      &  ecorr,wcorr,
1060      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1061      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1062      &  ebr*nss,Uconst,etot
1063    10 format (/'Virtual-chain energies:'//
1064      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1065      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1066      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1067      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1068      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1069      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1070      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1071      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1072      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1073      & ' (SS bridges & dist. cnstr.)'/
1074      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1075      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1076      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1077      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1078      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1079      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1080      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1081      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1082      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1083      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1084      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1085      & 'ETOT=  ',1pE16.6,' (total)')
1086 #endif
1087       return
1088       end
1089 C-----------------------------------------------------------------------
1090       subroutine elj(evdw,evdw_p,evdw_m)
1091 C
1092 C This subroutine calculates the interaction energy of nonbonded side chains
1093 C assuming the LJ potential of interaction.
1094 C
1095       implicit real*8 (a-h,o-z)
1096       include 'DIMENSIONS'
1097       parameter (accur=1.0d-10)
1098       include 'COMMON.GEO'
1099       include 'COMMON.VAR'
1100       include 'COMMON.LOCAL'
1101       include 'COMMON.CHAIN'
1102       include 'COMMON.DERIV'
1103       include 'COMMON.INTERACT'
1104       include 'COMMON.TORSION'
1105       include 'COMMON.SBRIDGE'
1106       include 'COMMON.NAMES'
1107       include 'COMMON.IOUNITS'
1108       include 'COMMON.CONTACTS'
1109       dimension gg(3)
1110 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1111       evdw=0.0D0
1112       do i=iatsc_s,iatsc_e
1113         itypi=itype(i)
1114         itypi1=itype(i+1)
1115         xi=c(1,nres+i)
1116         yi=c(2,nres+i)
1117         zi=c(3,nres+i)
1118 C Change 12/1/95
1119         num_conti=0
1120 C
1121 C Calculate SC interaction energy.
1122 C
1123         do iint=1,nint_gr(i)
1124 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1125 cd   &                  'iend=',iend(i,iint)
1126           do j=istart(i,iint),iend(i,iint)
1127             itypj=itype(j)
1128             xj=c(1,nres+j)-xi
1129             yj=c(2,nres+j)-yi
1130             zj=c(3,nres+j)-zi
1131 C Change 12/1/95 to calculate four-body interactions
1132             rij=xj*xj+yj*yj+zj*zj
1133             rrij=1.0D0/rij
1134 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1135             eps0ij=eps(itypi,itypj)
1136             fac=rrij**expon2
1137             e1=fac*fac*aa(itypi,itypj)
1138             e2=fac*bb(itypi,itypj)
1139             evdwij=e1+e2
1140 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1141 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1142 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1143 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1144 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1145 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1146 #ifdef TSCSC
1147             if (bb(itypi,itypj).gt.0) then
1148                evdw_p=evdw_p+evdwij
1149             else
1150                evdw_m=evdw_m+evdwij
1151             endif
1152 #else
1153             evdw=evdw+evdwij
1154 #endif
1155 C
1156 C Calculate the components of the gradient in DC and X
1157 C
1158             fac=-rrij*(e1+evdwij)
1159             gg(1)=xj*fac
1160             gg(2)=yj*fac
1161             gg(3)=zj*fac
1162 #ifdef TSCSC
1163             if (bb(itypi,itypj).gt.0.0d0) then
1164               do k=1,3
1165                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1166                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1167                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1168                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1169               enddo
1170             else
1171               do k=1,3
1172                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1173                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1174                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1175                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1176               enddo
1177             endif
1178 #else
1179             do k=1,3
1180               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1181               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1182               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1183               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1184             enddo
1185 #endif
1186 cgrad            do k=i,j-1
1187 cgrad              do l=1,3
1188 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1189 cgrad              enddo
1190 cgrad            enddo
1191 C
1192 C 12/1/95, revised on 5/20/97
1193 C
1194 C Calculate the contact function. The ith column of the array JCONT will
1195 C contain the numbers of atoms that make contacts with the atom I (of numbers
1196 C greater than I). The arrays FACONT and GACONT will contain the values of
1197 C the contact function and its derivative.
1198 C
1199 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1200 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1201 C Uncomment next line, if the correlation interactions are contact function only
1202             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1203               rij=dsqrt(rij)
1204               sigij=sigma(itypi,itypj)
1205               r0ij=rs0(itypi,itypj)
1206 C
1207 C Check whether the SC's are not too far to make a contact.
1208 C
1209               rcut=1.5d0*r0ij
1210               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1211 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1212 C
1213               if (fcont.gt.0.0D0) then
1214 C If the SC-SC distance if close to sigma, apply spline.
1215 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1216 cAdam &             fcont1,fprimcont1)
1217 cAdam           fcont1=1.0d0-fcont1
1218 cAdam           if (fcont1.gt.0.0d0) then
1219 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1220 cAdam             fcont=fcont*fcont1
1221 cAdam           endif
1222 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1223 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1224 cga             do k=1,3
1225 cga               gg(k)=gg(k)*eps0ij
1226 cga             enddo
1227 cga             eps0ij=-evdwij*eps0ij
1228 C Uncomment for AL's type of SC correlation interactions.
1229 cadam           eps0ij=-evdwij
1230                 num_conti=num_conti+1
1231                 jcont(num_conti,i)=j
1232                 facont(num_conti,i)=fcont*eps0ij
1233                 fprimcont=eps0ij*fprimcont/rij
1234                 fcont=expon*fcont
1235 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1236 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1237 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1238 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1239                 gacont(1,num_conti,i)=-fprimcont*xj
1240                 gacont(2,num_conti,i)=-fprimcont*yj
1241                 gacont(3,num_conti,i)=-fprimcont*zj
1242 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1243 cd              write (iout,'(2i3,3f10.5)')
1244 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1245               endif
1246             endif
1247           enddo      ! j
1248         enddo        ! iint
1249 C Change 12/1/95
1250         num_cont(i)=num_conti
1251       enddo          ! i
1252       do i=1,nct
1253         do j=1,3
1254           gvdwc(j,i)=expon*gvdwc(j,i)
1255           gvdwx(j,i)=expon*gvdwx(j,i)
1256         enddo
1257       enddo
1258 C******************************************************************************
1259 C
1260 C                              N O T E !!!
1261 C
1262 C To save time, the factor of EXPON has been extracted from ALL components
1263 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1264 C use!
1265 C
1266 C******************************************************************************
1267       return
1268       end
1269 C-----------------------------------------------------------------------------
1270       subroutine eljk(evdw,evdw_p,evdw_m)
1271 C
1272 C This subroutine calculates the interaction energy of nonbonded side chains
1273 C assuming the LJK potential of interaction.
1274 C
1275       implicit real*8 (a-h,o-z)
1276       include 'DIMENSIONS'
1277       include 'COMMON.GEO'
1278       include 'COMMON.VAR'
1279       include 'COMMON.LOCAL'
1280       include 'COMMON.CHAIN'
1281       include 'COMMON.DERIV'
1282       include 'COMMON.INTERACT'
1283       include 'COMMON.IOUNITS'
1284       include 'COMMON.NAMES'
1285       dimension gg(3)
1286       logical scheck
1287 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1288       evdw=0.0D0
1289       do i=iatsc_s,iatsc_e
1290         itypi=itype(i)
1291         itypi1=itype(i+1)
1292         xi=c(1,nres+i)
1293         yi=c(2,nres+i)
1294         zi=c(3,nres+i)
1295 C
1296 C Calculate SC interaction energy.
1297 C
1298         do iint=1,nint_gr(i)
1299           do j=istart(i,iint),iend(i,iint)
1300             itypj=itype(j)
1301             xj=c(1,nres+j)-xi
1302             yj=c(2,nres+j)-yi
1303             zj=c(3,nres+j)-zi
1304             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1305             fac_augm=rrij**expon
1306             e_augm=augm(itypi,itypj)*fac_augm
1307             r_inv_ij=dsqrt(rrij)
1308             rij=1.0D0/r_inv_ij
1309             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1310             fac=r_shift_inv**expon
1311             e1=fac*fac*aa(itypi,itypj)
1312             e2=fac*bb(itypi,itypj)
1313             evdwij=e_augm+e1+e2
1314 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1315 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1316 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1317 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1318 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1319 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1320 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1321 #ifdef TSCSC
1322             if (bb(itypi,itypj).gt.0) then
1323                evdw_p=evdw_p+evdwij
1324             else
1325                evdw_m=evdw_m+evdwij
1326             endif
1327 #else
1328             evdw=evdw+evdwij
1329 #endif
1330 C
1331 C Calculate the components of the gradient in DC and X
1332 C
1333             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1334             gg(1)=xj*fac
1335             gg(2)=yj*fac
1336             gg(3)=zj*fac
1337 #ifdef TSCSC
1338             if (bb(itypi,itypj).gt.0.0d0) then
1339               do k=1,3
1340                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1341                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1342                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1343                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1344               enddo
1345             else
1346               do k=1,3
1347                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1348                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1349                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1350                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1351               enddo
1352             endif
1353 #else
1354             do k=1,3
1355               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1356               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1357               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1358               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1359             enddo
1360 #endif
1361 cgrad            do k=i,j-1
1362 cgrad              do l=1,3
1363 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1364 cgrad              enddo
1365 cgrad            enddo
1366           enddo      ! j
1367         enddo        ! iint
1368       enddo          ! i
1369       do i=1,nct
1370         do j=1,3
1371           gvdwc(j,i)=expon*gvdwc(j,i)
1372           gvdwx(j,i)=expon*gvdwx(j,i)
1373         enddo
1374       enddo
1375       return
1376       end
1377 C-----------------------------------------------------------------------------
1378       subroutine ebp(evdw,evdw_p,evdw_m)
1379 C
1380 C This subroutine calculates the interaction energy of nonbonded side chains
1381 C assuming the Berne-Pechukas potential of interaction.
1382 C
1383       implicit real*8 (a-h,o-z)
1384       include 'DIMENSIONS'
1385       include 'COMMON.GEO'
1386       include 'COMMON.VAR'
1387       include 'COMMON.LOCAL'
1388       include 'COMMON.CHAIN'
1389       include 'COMMON.DERIV'
1390       include 'COMMON.NAMES'
1391       include 'COMMON.INTERACT'
1392       include 'COMMON.IOUNITS'
1393       include 'COMMON.CALC'
1394       common /srutu/ icall
1395 c     double precision rrsave(maxdim)
1396       logical lprn
1397       evdw=0.0D0
1398 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1399       evdw=0.0D0
1400 c     if (icall.eq.0) then
1401 c       lprn=.true.
1402 c     else
1403         lprn=.false.
1404 c     endif
1405       ind=0
1406       do i=iatsc_s,iatsc_e
1407         itypi=itype(i)
1408         itypi1=itype(i+1)
1409         xi=c(1,nres+i)
1410         yi=c(2,nres+i)
1411         zi=c(3,nres+i)
1412         dxi=dc_norm(1,nres+i)
1413         dyi=dc_norm(2,nres+i)
1414         dzi=dc_norm(3,nres+i)
1415 c        dsci_inv=dsc_inv(itypi)
1416         dsci_inv=vbld_inv(i+nres)
1417 C
1418 C Calculate SC interaction energy.
1419 C
1420         do iint=1,nint_gr(i)
1421           do j=istart(i,iint),iend(i,iint)
1422             ind=ind+1
1423             itypj=itype(j)
1424 c            dscj_inv=dsc_inv(itypj)
1425             dscj_inv=vbld_inv(j+nres)
1426             chi1=chi(itypi,itypj)
1427             chi2=chi(itypj,itypi)
1428             chi12=chi1*chi2
1429             chip1=chip(itypi)
1430             chip2=chip(itypj)
1431             chip12=chip1*chip2
1432             alf1=alp(itypi)
1433             alf2=alp(itypj)
1434             alf12=0.5D0*(alf1+alf2)
1435 C For diagnostics only!!!
1436 c           chi1=0.0D0
1437 c           chi2=0.0D0
1438 c           chi12=0.0D0
1439 c           chip1=0.0D0
1440 c           chip2=0.0D0
1441 c           chip12=0.0D0
1442 c           alf1=0.0D0
1443 c           alf2=0.0D0
1444 c           alf12=0.0D0
1445             xj=c(1,nres+j)-xi
1446             yj=c(2,nres+j)-yi
1447             zj=c(3,nres+j)-zi
1448             dxj=dc_norm(1,nres+j)
1449             dyj=dc_norm(2,nres+j)
1450             dzj=dc_norm(3,nres+j)
1451             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1452 cd          if (icall.eq.0) then
1453 cd            rrsave(ind)=rrij
1454 cd          else
1455 cd            rrij=rrsave(ind)
1456 cd          endif
1457             rij=dsqrt(rrij)
1458 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1459             call sc_angular
1460 C Calculate whole angle-dependent part of epsilon and contributions
1461 C to its derivatives
1462             fac=(rrij*sigsq)**expon2
1463             e1=fac*fac*aa(itypi,itypj)
1464             e2=fac*bb(itypi,itypj)
1465             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1466             eps2der=evdwij*eps3rt
1467             eps3der=evdwij*eps2rt
1468             evdwij=evdwij*eps2rt*eps3rt
1469 #ifdef TSCSC
1470             if (bb(itypi,itypj).gt.0) then
1471                evdw_p=evdw_p+evdwij
1472             else
1473                evdw_m=evdw_m+evdwij
1474             endif
1475 #else
1476             evdw=evdw+evdwij
1477 #endif
1478             if (lprn) then
1479             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1480             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1481 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1482 cd     &        restyp(itypi),i,restyp(itypj),j,
1483 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1484 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1485 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1486 cd     &        evdwij
1487             endif
1488 C Calculate gradient components.
1489             e1=e1*eps1*eps2rt**2*eps3rt**2
1490             fac=-expon*(e1+evdwij)
1491             sigder=fac/sigsq
1492             fac=rrij*fac
1493 C Calculate radial part of the gradient
1494             gg(1)=xj*fac
1495             gg(2)=yj*fac
1496             gg(3)=zj*fac
1497 C Calculate the angular part of the gradient and sum add the contributions
1498 C to the appropriate components of the Cartesian gradient.
1499 #ifdef TSCSC
1500             if (bb(itypi,itypj).gt.0) then
1501                call sc_grad
1502             else
1503                call sc_grad_T
1504             endif
1505 #else
1506             call sc_grad
1507 #endif
1508           enddo      ! j
1509         enddo        ! iint
1510       enddo          ! i
1511 c     stop
1512       return
1513       end
1514 C-----------------------------------------------------------------------------
1515       subroutine egb(evdw,evdw_p,evdw_m)
1516 C
1517 C This subroutine calculates the interaction energy of nonbonded side chains
1518 C assuming the Gay-Berne potential of interaction.
1519 C
1520       implicit real*8 (a-h,o-z)
1521       include 'DIMENSIONS'
1522       include 'COMMON.GEO'
1523       include 'COMMON.VAR'
1524       include 'COMMON.LOCAL'
1525       include 'COMMON.CHAIN'
1526       include 'COMMON.DERIV'
1527       include 'COMMON.NAMES'
1528       include 'COMMON.INTERACT'
1529       include 'COMMON.IOUNITS'
1530       include 'COMMON.CALC'
1531       include 'COMMON.CONTROL'
1532       logical lprn
1533       evdw=0.0D0
1534 ccccc      energy_dec=.false.
1535 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1536       evdw=0.0D0
1537       evdw_p=0.0D0
1538       evdw_m=0.0D0
1539       lprn=.false.
1540 c     if (icall.eq.0) lprn=.false.
1541       ind=0
1542       do i=iatsc_s,iatsc_e
1543         itypi=itype(i)
1544         itypi1=itype(i+1)
1545         xi=c(1,nres+i)
1546         yi=c(2,nres+i)
1547         zi=c(3,nres+i)
1548         dxi=dc_norm(1,nres+i)
1549         dyi=dc_norm(2,nres+i)
1550         dzi=dc_norm(3,nres+i)
1551 c        dsci_inv=dsc_inv(itypi)
1552         dsci_inv=vbld_inv(i+nres)
1553 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1554 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1555 C
1556 C Calculate SC interaction energy.
1557 C
1558         do iint=1,nint_gr(i)
1559           do j=istart(i,iint),iend(i,iint)
1560             ind=ind+1
1561             itypj=itype(j)
1562 c            dscj_inv=dsc_inv(itypj)
1563             dscj_inv=vbld_inv(j+nres)
1564 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1565 c     &       1.0d0/vbld(j+nres)
1566 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1567             sig0ij=sigma(itypi,itypj)
1568             chi1=chi(itypi,itypj)
1569             chi2=chi(itypj,itypi)
1570             chi12=chi1*chi2
1571             chip1=chip(itypi)
1572             chip2=chip(itypj)
1573             chip12=chip1*chip2
1574             alf1=alp(itypi)
1575             alf2=alp(itypj)
1576             alf12=0.5D0*(alf1+alf2)
1577 C For diagnostics only!!!
1578 c           chi1=0.0D0
1579 c           chi2=0.0D0
1580 c           chi12=0.0D0
1581 c           chip1=0.0D0
1582 c           chip2=0.0D0
1583 c           chip12=0.0D0
1584 c           alf1=0.0D0
1585 c           alf2=0.0D0
1586 c           alf12=0.0D0
1587             xj=c(1,nres+j)-xi
1588             yj=c(2,nres+j)-yi
1589             zj=c(3,nres+j)-zi
1590             dxj=dc_norm(1,nres+j)
1591             dyj=dc_norm(2,nres+j)
1592             dzj=dc_norm(3,nres+j)
1593 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1594 c            write (iout,*) "j",j," dc_norm",
1595 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1596             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1597             rij=dsqrt(rrij)
1598 C Calculate angle-dependent terms of energy and contributions to their
1599 C derivatives.
1600             call sc_angular
1601             sigsq=1.0D0/sigsq
1602             sig=sig0ij*dsqrt(sigsq)
1603             rij_shift=1.0D0/rij-sig+sig0ij
1604 c for diagnostics; uncomment
1605 c            rij_shift=1.2*sig0ij
1606 C I hate to put IF's in the loops, but here don't have another choice!!!!
1607             if (rij_shift.le.0.0D0) then
1608               evdw=1.0D20
1609 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1610 cd     &        restyp(itypi),i,restyp(itypj),j,
1611 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1612               return
1613             endif
1614             sigder=-sig*sigsq
1615 c---------------------------------------------------------------
1616             rij_shift=1.0D0/rij_shift
1617             fac=rij_shift**expon
1618             e1=fac*fac*aa(itypi,itypj)
1619             e2=fac*bb(itypi,itypj)
1620             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1621             eps2der=evdwij*eps3rt
1622             eps3der=evdwij*eps2rt
1623 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1624 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1625             evdwij=evdwij*eps2rt*eps3rt
1626 #ifdef TSCSC
1627             if (bb(itypi,itypj).gt.0) then
1628                evdw_p=evdw_p+evdwij
1629             else
1630                evdw_m=evdw_m+evdwij
1631             endif
1632 #else
1633             evdw=evdw+evdwij
1634 #endif
1635             if (lprn) then
1636             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1637             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1638             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1639      &        restyp(itypi),i,restyp(itypj),j,
1640      &        epsi,sigm,chi1,chi2,chip1,chip2,
1641      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1642      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1643      &        evdwij
1644             endif
1645
1646             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1647      &                        'evdw',i,j,evdwij
1648
1649 C Calculate gradient components.
1650             e1=e1*eps1*eps2rt**2*eps3rt**2
1651             fac=-expon*(e1+evdwij)*rij_shift
1652             sigder=fac*sigder
1653             fac=rij*fac
1654 c            fac=0.0d0
1655 C Calculate the radial part of the gradient
1656             gg(1)=xj*fac
1657             gg(2)=yj*fac
1658             gg(3)=zj*fac
1659 C Calculate angular part of the gradient.
1660 #ifdef TSCSC
1661             if (bb(itypi,itypj).gt.0) then
1662                call sc_grad
1663             else
1664                call sc_grad_T
1665             endif
1666 #else
1667             call sc_grad
1668 #endif
1669           enddo      ! j
1670         enddo        ! iint
1671       enddo          ! i
1672 c      write (iout,*) "Number of loop steps in EGB:",ind
1673 cccc      energy_dec=.false.
1674       return
1675       end
1676 C-----------------------------------------------------------------------------
1677       subroutine egbv(evdw,evdw_p,evdw_m)
1678 C
1679 C This subroutine calculates the interaction energy of nonbonded side chains
1680 C assuming the Gay-Berne-Vorobjev potential of interaction.
1681 C
1682       implicit real*8 (a-h,o-z)
1683       include 'DIMENSIONS'
1684       include 'COMMON.GEO'
1685       include 'COMMON.VAR'
1686       include 'COMMON.LOCAL'
1687       include 'COMMON.CHAIN'
1688       include 'COMMON.DERIV'
1689       include 'COMMON.NAMES'
1690       include 'COMMON.INTERACT'
1691       include 'COMMON.IOUNITS'
1692       include 'COMMON.CALC'
1693       common /srutu/ icall
1694       logical lprn
1695       evdw=0.0D0
1696 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1697       evdw=0.0D0
1698       lprn=.false.
1699 c     if (icall.eq.0) lprn=.true.
1700       ind=0
1701       do i=iatsc_s,iatsc_e
1702         itypi=itype(i)
1703         itypi1=itype(i+1)
1704         xi=c(1,nres+i)
1705         yi=c(2,nres+i)
1706         zi=c(3,nres+i)
1707         dxi=dc_norm(1,nres+i)
1708         dyi=dc_norm(2,nres+i)
1709         dzi=dc_norm(3,nres+i)
1710 c        dsci_inv=dsc_inv(itypi)
1711         dsci_inv=vbld_inv(i+nres)
1712 C
1713 C Calculate SC interaction energy.
1714 C
1715         do iint=1,nint_gr(i)
1716           do j=istart(i,iint),iend(i,iint)
1717             ind=ind+1
1718             itypj=itype(j)
1719 c            dscj_inv=dsc_inv(itypj)
1720             dscj_inv=vbld_inv(j+nres)
1721             sig0ij=sigma(itypi,itypj)
1722             r0ij=r0(itypi,itypj)
1723             chi1=chi(itypi,itypj)
1724             chi2=chi(itypj,itypi)
1725             chi12=chi1*chi2
1726             chip1=chip(itypi)
1727             chip2=chip(itypj)
1728             chip12=chip1*chip2
1729             alf1=alp(itypi)
1730             alf2=alp(itypj)
1731             alf12=0.5D0*(alf1+alf2)
1732 C For diagnostics only!!!
1733 c           chi1=0.0D0
1734 c           chi2=0.0D0
1735 c           chi12=0.0D0
1736 c           chip1=0.0D0
1737 c           chip2=0.0D0
1738 c           chip12=0.0D0
1739 c           alf1=0.0D0
1740 c           alf2=0.0D0
1741 c           alf12=0.0D0
1742             xj=c(1,nres+j)-xi
1743             yj=c(2,nres+j)-yi
1744             zj=c(3,nres+j)-zi
1745             dxj=dc_norm(1,nres+j)
1746             dyj=dc_norm(2,nres+j)
1747             dzj=dc_norm(3,nres+j)
1748             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1749             rij=dsqrt(rrij)
1750 C Calculate angle-dependent terms of energy and contributions to their
1751 C derivatives.
1752             call sc_angular
1753             sigsq=1.0D0/sigsq
1754             sig=sig0ij*dsqrt(sigsq)
1755             rij_shift=1.0D0/rij-sig+r0ij
1756 C I hate to put IF's in the loops, but here don't have another choice!!!!
1757             if (rij_shift.le.0.0D0) then
1758               evdw=1.0D20
1759               return
1760             endif
1761             sigder=-sig*sigsq
1762 c---------------------------------------------------------------
1763             rij_shift=1.0D0/rij_shift
1764             fac=rij_shift**expon
1765             e1=fac*fac*aa(itypi,itypj)
1766             e2=fac*bb(itypi,itypj)
1767             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1768             eps2der=evdwij*eps3rt
1769             eps3der=evdwij*eps2rt
1770             fac_augm=rrij**expon
1771             e_augm=augm(itypi,itypj)*fac_augm
1772             evdwij=evdwij*eps2rt*eps3rt
1773 #ifdef TSCSC
1774             if (bb(itypi,itypj).gt.0) then
1775                evdw_p=evdw_p+evdwij+e_augm
1776             else
1777                evdw_m=evdw_m+evdwij+e_augm
1778             endif
1779 #else
1780             evdw=evdw+evdwij+e_augm
1781 #endif
1782             if (lprn) then
1783             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1784             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1785             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1786      &        restyp(itypi),i,restyp(itypj),j,
1787      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1788      &        chi1,chi2,chip1,chip2,
1789      &        eps1,eps2rt**2,eps3rt**2,
1790      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1791      &        evdwij+e_augm
1792             endif
1793 C Calculate gradient components.
1794             e1=e1*eps1*eps2rt**2*eps3rt**2
1795             fac=-expon*(e1+evdwij)*rij_shift
1796             sigder=fac*sigder
1797             fac=rij*fac-2*expon*rrij*e_augm
1798 C Calculate the radial part of the gradient
1799             gg(1)=xj*fac
1800             gg(2)=yj*fac
1801             gg(3)=zj*fac
1802 C Calculate angular part of the gradient.
1803 #ifdef TSCSC
1804             if (bb(itypi,itypj).gt.0) then
1805                call sc_grad
1806             else
1807                call sc_grad_T
1808             endif
1809 #else
1810             call sc_grad
1811 #endif
1812           enddo      ! j
1813         enddo        ! iint
1814       enddo          ! i
1815       end
1816 C-----------------------------------------------------------------------------
1817       subroutine sc_angular
1818 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1819 C om12. Called by ebp, egb, and egbv.
1820       implicit none
1821       include 'COMMON.CALC'
1822       include 'COMMON.IOUNITS'
1823       erij(1)=xj*rij
1824       erij(2)=yj*rij
1825       erij(3)=zj*rij
1826       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1827       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1828       om12=dxi*dxj+dyi*dyj+dzi*dzj
1829       chiom12=chi12*om12
1830 C Calculate eps1(om12) and its derivative in om12
1831       faceps1=1.0D0-om12*chiom12
1832       faceps1_inv=1.0D0/faceps1
1833       eps1=dsqrt(faceps1_inv)
1834 C Following variable is eps1*deps1/dom12
1835       eps1_om12=faceps1_inv*chiom12
1836 c diagnostics only
1837 c      faceps1_inv=om12
1838 c      eps1=om12
1839 c      eps1_om12=1.0d0
1840 c      write (iout,*) "om12",om12," eps1",eps1
1841 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1842 C and om12.
1843       om1om2=om1*om2
1844       chiom1=chi1*om1
1845       chiom2=chi2*om2
1846       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1847       sigsq=1.0D0-facsig*faceps1_inv
1848       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1849       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1850       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1851 c diagnostics only
1852 c      sigsq=1.0d0
1853 c      sigsq_om1=0.0d0
1854 c      sigsq_om2=0.0d0
1855 c      sigsq_om12=0.0d0
1856 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1857 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1858 c     &    " eps1",eps1
1859 C Calculate eps2 and its derivatives in om1, om2, and om12.
1860       chipom1=chip1*om1
1861       chipom2=chip2*om2
1862       chipom12=chip12*om12
1863       facp=1.0D0-om12*chipom12
1864       facp_inv=1.0D0/facp
1865       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1866 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1867 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1868 C Following variable is the square root of eps2
1869       eps2rt=1.0D0-facp1*facp_inv
1870 C Following three variables are the derivatives of the square root of eps
1871 C in om1, om2, and om12.
1872       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1873       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1874       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1875 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1876       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1877 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1878 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1879 c     &  " eps2rt_om12",eps2rt_om12
1880 C Calculate whole angle-dependent part of epsilon and contributions
1881 C to its derivatives
1882       return
1883       end
1884
1885 C----------------------------------------------------------------------------
1886       subroutine sc_grad_T
1887       implicit real*8 (a-h,o-z)
1888       include 'DIMENSIONS'
1889       include 'COMMON.CHAIN'
1890       include 'COMMON.DERIV'
1891       include 'COMMON.CALC'
1892       include 'COMMON.IOUNITS'
1893       double precision dcosom1(3),dcosom2(3)
1894       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1895       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1896       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1897      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1898 c diagnostics only
1899 c      eom1=0.0d0
1900 c      eom2=0.0d0
1901 c      eom12=evdwij*eps1_om12
1902 c end diagnostics
1903 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1904 c     &  " sigder",sigder
1905 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1906 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1907       do k=1,3
1908         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1909         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1910       enddo
1911       do k=1,3
1912         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1913       enddo
1914 c      write (iout,*) "gg",(gg(k),k=1,3)
1915       do k=1,3
1916         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1917      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1918      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1919         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1920      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1921      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1922 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1923 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1924 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1925 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1926       enddo
1927 C
1928 C Calculate the components of the gradient in DC and X
1929 C
1930 cgrad      do k=i,j-1
1931 cgrad        do l=1,3
1932 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1933 cgrad        enddo
1934 cgrad      enddo
1935       do l=1,3
1936         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1937         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1938       enddo
1939       return
1940       end
1941
1942 C----------------------------------------------------------------------------
1943       subroutine sc_grad
1944       implicit real*8 (a-h,o-z)
1945       include 'DIMENSIONS'
1946       include 'COMMON.CHAIN'
1947       include 'COMMON.DERIV'
1948       include 'COMMON.CALC'
1949       include 'COMMON.IOUNITS'
1950       double precision dcosom1(3),dcosom2(3)
1951       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1952       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1953       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1954      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1955 c diagnostics only
1956 c      eom1=0.0d0
1957 c      eom2=0.0d0
1958 c      eom12=evdwij*eps1_om12
1959 c end diagnostics
1960 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1961 c     &  " sigder",sigder
1962 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1963 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1964       do k=1,3
1965         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1966         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1967       enddo
1968       do k=1,3
1969         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1970       enddo
1971 c      write (iout,*) "gg",(gg(k),k=1,3)
1972       do k=1,3
1973         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1974      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1975      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1976         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1977      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1978      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1979 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1980 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1981 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1982 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1983       enddo
1984 C
1985 C Calculate the components of the gradient in DC and X
1986 C
1987 cgrad      do k=i,j-1
1988 cgrad        do l=1,3
1989 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1990 cgrad        enddo
1991 cgrad      enddo
1992       do l=1,3
1993         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1994         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1995       enddo
1996       return
1997       end
1998 C-----------------------------------------------------------------------
1999       subroutine e_softsphere(evdw)
2000 C
2001 C This subroutine calculates the interaction energy of nonbonded side chains
2002 C assuming the LJ potential of interaction.
2003 C
2004       implicit real*8 (a-h,o-z)
2005       include 'DIMENSIONS'
2006       parameter (accur=1.0d-10)
2007       include 'COMMON.GEO'
2008       include 'COMMON.VAR'
2009       include 'COMMON.LOCAL'
2010       include 'COMMON.CHAIN'
2011       include 'COMMON.DERIV'
2012       include 'COMMON.INTERACT'
2013       include 'COMMON.TORSION'
2014       include 'COMMON.SBRIDGE'
2015       include 'COMMON.NAMES'
2016       include 'COMMON.IOUNITS'
2017       include 'COMMON.CONTACTS'
2018       dimension gg(3)
2019 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2020       evdw=0.0D0
2021       do i=iatsc_s,iatsc_e
2022         itypi=itype(i)
2023         itypi1=itype(i+1)
2024         xi=c(1,nres+i)
2025         yi=c(2,nres+i)
2026         zi=c(3,nres+i)
2027 C
2028 C Calculate SC interaction energy.
2029 C
2030         do iint=1,nint_gr(i)
2031 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2032 cd   &                  'iend=',iend(i,iint)
2033           do j=istart(i,iint),iend(i,iint)
2034             itypj=itype(j)
2035             xj=c(1,nres+j)-xi
2036             yj=c(2,nres+j)-yi
2037             zj=c(3,nres+j)-zi
2038             rij=xj*xj+yj*yj+zj*zj
2039 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2040             r0ij=r0(itypi,itypj)
2041             r0ijsq=r0ij*r0ij
2042 c            print *,i,j,r0ij,dsqrt(rij)
2043             if (rij.lt.r0ijsq) then
2044               evdwij=0.25d0*(rij-r0ijsq)**2
2045               fac=rij-r0ijsq
2046             else
2047               evdwij=0.0d0
2048               fac=0.0d0
2049             endif
2050             evdw=evdw+evdwij
2051 C
2052 C Calculate the components of the gradient in DC and X
2053 C
2054             gg(1)=xj*fac
2055             gg(2)=yj*fac
2056             gg(3)=zj*fac
2057             do k=1,3
2058               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2059               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2060               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2061               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2062             enddo
2063 cgrad            do k=i,j-1
2064 cgrad              do l=1,3
2065 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2066 cgrad              enddo
2067 cgrad            enddo
2068           enddo ! j
2069         enddo ! iint
2070       enddo ! i
2071       return
2072       end
2073 C--------------------------------------------------------------------------
2074       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2075      &              eello_turn4)
2076 C
2077 C Soft-sphere potential of p-p interaction
2078 C
2079       implicit real*8 (a-h,o-z)
2080       include 'DIMENSIONS'
2081       include 'COMMON.CONTROL'
2082       include 'COMMON.IOUNITS'
2083       include 'COMMON.GEO'
2084       include 'COMMON.VAR'
2085       include 'COMMON.LOCAL'
2086       include 'COMMON.CHAIN'
2087       include 'COMMON.DERIV'
2088       include 'COMMON.INTERACT'
2089       include 'COMMON.CONTACTS'
2090       include 'COMMON.TORSION'
2091       include 'COMMON.VECTORS'
2092       include 'COMMON.FFIELD'
2093       dimension ggg(3)
2094 cd      write(iout,*) 'In EELEC_soft_sphere'
2095       ees=0.0D0
2096       evdw1=0.0D0
2097       eel_loc=0.0d0
2098       eello_turn3=0.0d0
2099       eello_turn4=0.0d0
2100       ind=0
2101       do i=iatel_s,iatel_e
2102         dxi=dc(1,i)
2103         dyi=dc(2,i)
2104         dzi=dc(3,i)
2105         xmedi=c(1,i)+0.5d0*dxi
2106         ymedi=c(2,i)+0.5d0*dyi
2107         zmedi=c(3,i)+0.5d0*dzi
2108         num_conti=0
2109 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2110         do j=ielstart(i),ielend(i)
2111           ind=ind+1
2112           iteli=itel(i)
2113           itelj=itel(j)
2114           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2115           r0ij=rpp(iteli,itelj)
2116           r0ijsq=r0ij*r0ij
2117           dxj=dc(1,j)
2118           dyj=dc(2,j)
2119           dzj=dc(3,j)
2120           xj=c(1,j)+0.5D0*dxj-xmedi
2121           yj=c(2,j)+0.5D0*dyj-ymedi
2122           zj=c(3,j)+0.5D0*dzj-zmedi
2123           rij=xj*xj+yj*yj+zj*zj
2124           if (rij.lt.r0ijsq) then
2125             evdw1ij=0.25d0*(rij-r0ijsq)**2
2126             fac=rij-r0ijsq
2127           else
2128             evdw1ij=0.0d0
2129             fac=0.0d0
2130           endif
2131           evdw1=evdw1+evdw1ij
2132 C
2133 C Calculate contributions to the Cartesian gradient.
2134 C
2135           ggg(1)=fac*xj
2136           ggg(2)=fac*yj
2137           ggg(3)=fac*zj
2138           do k=1,3
2139             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2140             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2141           enddo
2142 *
2143 * Loop over residues i+1 thru j-1.
2144 *
2145 cgrad          do k=i+1,j-1
2146 cgrad            do l=1,3
2147 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2148 cgrad            enddo
2149 cgrad          enddo
2150         enddo ! j
2151       enddo   ! i
2152 cgrad      do i=nnt,nct-1
2153 cgrad        do k=1,3
2154 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2155 cgrad        enddo
2156 cgrad        do j=i+1,nct-1
2157 cgrad          do k=1,3
2158 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2159 cgrad          enddo
2160 cgrad        enddo
2161 cgrad      enddo
2162       return
2163       end
2164 c------------------------------------------------------------------------------
2165       subroutine vec_and_deriv
2166       implicit real*8 (a-h,o-z)
2167       include 'DIMENSIONS'
2168 #ifdef MPI
2169       include 'mpif.h'
2170 #endif
2171       include 'COMMON.IOUNITS'
2172       include 'COMMON.GEO'
2173       include 'COMMON.VAR'
2174       include 'COMMON.LOCAL'
2175       include 'COMMON.CHAIN'
2176       include 'COMMON.VECTORS'
2177       include 'COMMON.SETUP'
2178       include 'COMMON.TIME1'
2179       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2180 C Compute the local reference systems. For reference system (i), the
2181 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2182 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2183 #ifdef PARVEC
2184       do i=ivec_start,ivec_end
2185 #else
2186       do i=1,nres-1
2187 #endif
2188           if (i.eq.nres-1) then
2189 C Case of the last full residue
2190 C Compute the Z-axis
2191             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2192             costh=dcos(pi-theta(nres))
2193             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2194             do k=1,3
2195               uz(k,i)=fac*uz(k,i)
2196             enddo
2197 C Compute the derivatives of uz
2198             uzder(1,1,1)= 0.0d0
2199             uzder(2,1,1)=-dc_norm(3,i-1)
2200             uzder(3,1,1)= dc_norm(2,i-1)
2201             uzder(1,2,1)= dc_norm(3,i-1)
2202             uzder(2,2,1)= 0.0d0
2203             uzder(3,2,1)=-dc_norm(1,i-1)
2204             uzder(1,3,1)=-dc_norm(2,i-1)
2205             uzder(2,3,1)= dc_norm(1,i-1)
2206             uzder(3,3,1)= 0.0d0
2207             uzder(1,1,2)= 0.0d0
2208             uzder(2,1,2)= dc_norm(3,i)
2209             uzder(3,1,2)=-dc_norm(2,i)
2210             uzder(1,2,2)=-dc_norm(3,i)
2211             uzder(2,2,2)= 0.0d0
2212             uzder(3,2,2)= dc_norm(1,i)
2213             uzder(1,3,2)= dc_norm(2,i)
2214             uzder(2,3,2)=-dc_norm(1,i)
2215             uzder(3,3,2)= 0.0d0
2216 C Compute the Y-axis
2217             facy=fac
2218             do k=1,3
2219               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2220             enddo
2221 C Compute the derivatives of uy
2222             do j=1,3
2223               do k=1,3
2224                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2225      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2226                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2227               enddo
2228               uyder(j,j,1)=uyder(j,j,1)-costh
2229               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2230             enddo
2231             do j=1,2
2232               do k=1,3
2233                 do l=1,3
2234                   uygrad(l,k,j,i)=uyder(l,k,j)
2235                   uzgrad(l,k,j,i)=uzder(l,k,j)
2236                 enddo
2237               enddo
2238             enddo
2239             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2240             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2241             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2242             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2243           else
2244 C Other residues
2245 C Compute the Z-axis
2246             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2247             costh=dcos(pi-theta(i+2))
2248             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2249             do k=1,3
2250               uz(k,i)=fac*uz(k,i)
2251             enddo
2252 C Compute the derivatives of uz
2253             uzder(1,1,1)= 0.0d0
2254             uzder(2,1,1)=-dc_norm(3,i+1)
2255             uzder(3,1,1)= dc_norm(2,i+1)
2256             uzder(1,2,1)= dc_norm(3,i+1)
2257             uzder(2,2,1)= 0.0d0
2258             uzder(3,2,1)=-dc_norm(1,i+1)
2259             uzder(1,3,1)=-dc_norm(2,i+1)
2260             uzder(2,3,1)= dc_norm(1,i+1)
2261             uzder(3,3,1)= 0.0d0
2262             uzder(1,1,2)= 0.0d0
2263             uzder(2,1,2)= dc_norm(3,i)
2264             uzder(3,1,2)=-dc_norm(2,i)
2265             uzder(1,2,2)=-dc_norm(3,i)
2266             uzder(2,2,2)= 0.0d0
2267             uzder(3,2,2)= dc_norm(1,i)
2268             uzder(1,3,2)= dc_norm(2,i)
2269             uzder(2,3,2)=-dc_norm(1,i)
2270             uzder(3,3,2)= 0.0d0
2271 C Compute the Y-axis
2272             facy=fac
2273             do k=1,3
2274               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2275             enddo
2276 C Compute the derivatives of uy
2277             do j=1,3
2278               do k=1,3
2279                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2280      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2281                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2282               enddo
2283               uyder(j,j,1)=uyder(j,j,1)-costh
2284               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2285             enddo
2286             do j=1,2
2287               do k=1,3
2288                 do l=1,3
2289                   uygrad(l,k,j,i)=uyder(l,k,j)
2290                   uzgrad(l,k,j,i)=uzder(l,k,j)
2291                 enddo
2292               enddo
2293             enddo
2294             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2295             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2296             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2297             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2298           endif
2299       enddo
2300       do i=1,nres-1
2301         vbld_inv_temp(1)=vbld_inv(i+1)
2302         if (i.lt.nres-1) then
2303           vbld_inv_temp(2)=vbld_inv(i+2)
2304           else
2305           vbld_inv_temp(2)=vbld_inv(i)
2306           endif
2307         do j=1,2
2308           do k=1,3
2309             do l=1,3
2310               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2311               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2312             enddo
2313           enddo
2314         enddo
2315       enddo
2316 #if defined(PARVEC) && defined(MPI)
2317       if (nfgtasks1.gt.1) then
2318         time00=MPI_Wtime()
2319 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2320 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2321 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2322         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2323      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2324      &   FG_COMM1,IERR)
2325         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2326      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2327      &   FG_COMM1,IERR)
2328         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2329      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2330      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2331         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2332      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2333      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2334         time_gather=time_gather+MPI_Wtime()-time00
2335       endif
2336 c      if (fg_rank.eq.0) then
2337 c        write (iout,*) "Arrays UY and UZ"
2338 c        do i=1,nres-1
2339 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2340 c     &     (uz(k,i),k=1,3)
2341 c        enddo
2342 c      endif
2343 #endif
2344       return
2345       end
2346 C-----------------------------------------------------------------------------
2347       subroutine check_vecgrad
2348       implicit real*8 (a-h,o-z)
2349       include 'DIMENSIONS'
2350       include 'COMMON.IOUNITS'
2351       include 'COMMON.GEO'
2352       include 'COMMON.VAR'
2353       include 'COMMON.LOCAL'
2354       include 'COMMON.CHAIN'
2355       include 'COMMON.VECTORS'
2356       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2357       dimension uyt(3,maxres),uzt(3,maxres)
2358       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2359       double precision delta /1.0d-7/
2360       call vec_and_deriv
2361 cd      do i=1,nres
2362 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2363 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2364 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2365 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2366 cd     &     (dc_norm(if90,i),if90=1,3)
2367 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2368 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2369 cd          write(iout,'(a)')
2370 cd      enddo
2371       do i=1,nres
2372         do j=1,2
2373           do k=1,3
2374             do l=1,3
2375               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2376               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2377             enddo
2378           enddo
2379         enddo
2380       enddo
2381       call vec_and_deriv
2382       do i=1,nres
2383         do j=1,3
2384           uyt(j,i)=uy(j,i)
2385           uzt(j,i)=uz(j,i)
2386         enddo
2387       enddo
2388       do i=1,nres
2389 cd        write (iout,*) 'i=',i
2390         do k=1,3
2391           erij(k)=dc_norm(k,i)
2392         enddo
2393         do j=1,3
2394           do k=1,3
2395             dc_norm(k,i)=erij(k)
2396           enddo
2397           dc_norm(j,i)=dc_norm(j,i)+delta
2398 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2399 c          do k=1,3
2400 c            dc_norm(k,i)=dc_norm(k,i)/fac
2401 c          enddo
2402 c          write (iout,*) (dc_norm(k,i),k=1,3)
2403 c          write (iout,*) (erij(k),k=1,3)
2404           call vec_and_deriv
2405           do k=1,3
2406             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2407             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2408             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2409             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2410           enddo
2411 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2412 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2413 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2414         enddo
2415         do k=1,3
2416           dc_norm(k,i)=erij(k)
2417         enddo
2418 cd        do k=1,3
2419 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2420 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2421 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2422 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2423 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2424 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2425 cd          write (iout,'(a)')
2426 cd        enddo
2427       enddo
2428       return
2429       end
2430 C--------------------------------------------------------------------------
2431       subroutine set_matrices
2432       implicit real*8 (a-h,o-z)
2433       include 'DIMENSIONS'
2434 #ifdef MPI
2435       include "mpif.h"
2436       include "COMMON.SETUP"
2437       integer IERR
2438       integer status(MPI_STATUS_SIZE)
2439 #endif
2440       include 'COMMON.IOUNITS'
2441       include 'COMMON.GEO'
2442       include 'COMMON.VAR'
2443       include 'COMMON.LOCAL'
2444       include 'COMMON.CHAIN'
2445       include 'COMMON.DERIV'
2446       include 'COMMON.INTERACT'
2447       include 'COMMON.CONTACTS'
2448       include 'COMMON.TORSION'
2449       include 'COMMON.VECTORS'
2450       include 'COMMON.FFIELD'
2451       double precision auxvec(2),auxmat(2,2)
2452 C
2453 C Compute the virtual-bond-torsional-angle dependent quantities needed
2454 C to calculate the el-loc multibody terms of various order.
2455 C
2456 #ifdef PARMAT
2457       do i=ivec_start+2,ivec_end+2
2458 #else
2459       do i=3,nres+1
2460 #endif
2461         if (i .lt. nres+1) then
2462           sin1=dsin(phi(i))
2463           cos1=dcos(phi(i))
2464           sintab(i-2)=sin1
2465           costab(i-2)=cos1
2466           obrot(1,i-2)=cos1
2467           obrot(2,i-2)=sin1
2468           sin2=dsin(2*phi(i))
2469           cos2=dcos(2*phi(i))
2470           sintab2(i-2)=sin2
2471           costab2(i-2)=cos2
2472           obrot2(1,i-2)=cos2
2473           obrot2(2,i-2)=sin2
2474           Ug(1,1,i-2)=-cos1
2475           Ug(1,2,i-2)=-sin1
2476           Ug(2,1,i-2)=-sin1
2477           Ug(2,2,i-2)= cos1
2478           Ug2(1,1,i-2)=-cos2
2479           Ug2(1,2,i-2)=-sin2
2480           Ug2(2,1,i-2)=-sin2
2481           Ug2(2,2,i-2)= cos2
2482         else
2483           costab(i-2)=1.0d0
2484           sintab(i-2)=0.0d0
2485           obrot(1,i-2)=1.0d0
2486           obrot(2,i-2)=0.0d0
2487           obrot2(1,i-2)=0.0d0
2488           obrot2(2,i-2)=0.0d0
2489           Ug(1,1,i-2)=1.0d0
2490           Ug(1,2,i-2)=0.0d0
2491           Ug(2,1,i-2)=0.0d0
2492           Ug(2,2,i-2)=1.0d0
2493           Ug2(1,1,i-2)=0.0d0
2494           Ug2(1,2,i-2)=0.0d0
2495           Ug2(2,1,i-2)=0.0d0
2496           Ug2(2,2,i-2)=0.0d0
2497         endif
2498         if (i .gt. 3 .and. i .lt. nres+1) then
2499           obrot_der(1,i-2)=-sin1
2500           obrot_der(2,i-2)= cos1
2501           Ugder(1,1,i-2)= sin1
2502           Ugder(1,2,i-2)=-cos1
2503           Ugder(2,1,i-2)=-cos1
2504           Ugder(2,2,i-2)=-sin1
2505           dwacos2=cos2+cos2
2506           dwasin2=sin2+sin2
2507           obrot2_der(1,i-2)=-dwasin2
2508           obrot2_der(2,i-2)= dwacos2
2509           Ug2der(1,1,i-2)= dwasin2
2510           Ug2der(1,2,i-2)=-dwacos2
2511           Ug2der(2,1,i-2)=-dwacos2
2512           Ug2der(2,2,i-2)=-dwasin2
2513         else
2514           obrot_der(1,i-2)=0.0d0
2515           obrot_der(2,i-2)=0.0d0
2516           Ugder(1,1,i-2)=0.0d0
2517           Ugder(1,2,i-2)=0.0d0
2518           Ugder(2,1,i-2)=0.0d0
2519           Ugder(2,2,i-2)=0.0d0
2520           obrot2_der(1,i-2)=0.0d0
2521           obrot2_der(2,i-2)=0.0d0
2522           Ug2der(1,1,i-2)=0.0d0
2523           Ug2der(1,2,i-2)=0.0d0
2524           Ug2der(2,1,i-2)=0.0d0
2525           Ug2der(2,2,i-2)=0.0d0
2526         endif
2527 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2528         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2529           iti = itortyp(itype(i-2))
2530         else
2531           iti=ntortyp+1
2532         endif
2533 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2534         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2535           iti1 = itortyp(itype(i-1))
2536         else
2537           iti1=ntortyp+1
2538         endif
2539 cd        write (iout,*) '*******i',i,' iti1',iti
2540 cd        write (iout,*) 'b1',b1(:,iti)
2541 cd        write (iout,*) 'b2',b2(:,iti)
2542 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2543 c        if (i .gt. iatel_s+2) then
2544         if (i .gt. nnt+2) then
2545           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2546           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2547           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2548      &    then
2549           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2550           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2551           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2552           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2553           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2554           endif
2555         else
2556           do k=1,2
2557             Ub2(k,i-2)=0.0d0
2558             Ctobr(k,i-2)=0.0d0
2559             Dtobr2(k,i-2)=0.0d0
2560             do l=1,2
2561               EUg(l,k,i-2)=0.0d0
2562               CUg(l,k,i-2)=0.0d0
2563               DUg(l,k,i-2)=0.0d0
2564               DtUg2(l,k,i-2)=0.0d0
2565             enddo
2566           enddo
2567         endif
2568         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2569         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2570         do k=1,2
2571           muder(k,i-2)=Ub2der(k,i-2)
2572         enddo
2573 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2574         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2575           iti1 = itortyp(itype(i-1))
2576         else
2577           iti1=ntortyp+1
2578         endif
2579         do k=1,2
2580           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2581         enddo
2582 cd        write (iout,*) 'mu ',mu(:,i-2)
2583 cd        write (iout,*) 'mu1',mu1(:,i-2)
2584 cd        write (iout,*) 'mu2',mu2(:,i-2)
2585         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2586      &  then
2587         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2588         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2589         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2590         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2591         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2592 C Vectors and matrices dependent on a single virtual-bond dihedral.
2593         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2594         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2595         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2596         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2597         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2598         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2599         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2600         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2601         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2602         endif
2603       enddo
2604 C Matrices dependent on two consecutive virtual-bond dihedrals.
2605 C The order of matrices is from left to right.
2606       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2607      &then
2608 c      do i=max0(ivec_start,2),ivec_end
2609       do i=2,nres-1
2610         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2611         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2612         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2613         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2614         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2615         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2616         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2617         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2618       enddo
2619       endif
2620 #if defined(MPI) && defined(PARMAT)
2621 #ifdef DEBUG
2622 c      if (fg_rank.eq.0) then
2623         write (iout,*) "Arrays UG and UGDER before GATHER"
2624         do i=1,nres-1
2625           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2626      &     ((ug(l,k,i),l=1,2),k=1,2),
2627      &     ((ugder(l,k,i),l=1,2),k=1,2)
2628         enddo
2629         write (iout,*) "Arrays UG2 and UG2DER"
2630         do i=1,nres-1
2631           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2632      &     ((ug2(l,k,i),l=1,2),k=1,2),
2633      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2634         enddo
2635         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2636         do i=1,nres-1
2637           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2638      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2639      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2640         enddo
2641         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2642         do i=1,nres-1
2643           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2644      &     costab(i),sintab(i),costab2(i),sintab2(i)
2645         enddo
2646         write (iout,*) "Array MUDER"
2647         do i=1,nres-1
2648           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2649         enddo
2650 c      endif
2651 #endif
2652       if (nfgtasks.gt.1) then
2653         time00=MPI_Wtime()
2654 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2655 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2656 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2657 #ifdef MATGATHER
2658         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2659      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2660      &   FG_COMM1,IERR)
2661         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2662      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2663      &   FG_COMM1,IERR)
2664         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2665      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2666      &   FG_COMM1,IERR)
2667         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2668      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2669      &   FG_COMM1,IERR)
2670         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2671      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2672      &   FG_COMM1,IERR)
2673         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2674      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2675      &   FG_COMM1,IERR)
2676         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2677      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2678      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2679         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2680      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2681      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2682         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2683      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2684      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2685         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2686      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2687      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2688         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2689      &  then
2690         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2691      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2692      &   FG_COMM1,IERR)
2693         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2694      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2695      &   FG_COMM1,IERR)
2696         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2697      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2698      &   FG_COMM1,IERR)
2699        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2700      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2701      &   FG_COMM1,IERR)
2702         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2703      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2704      &   FG_COMM1,IERR)
2705         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2706      &   ivec_count(fg_rank1),
2707      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2708      &   FG_COMM1,IERR)
2709         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2710      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2711      &   FG_COMM1,IERR)
2712         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2713      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2714      &   FG_COMM1,IERR)
2715         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2716      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2717      &   FG_COMM1,IERR)
2718         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2719      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2720      &   FG_COMM1,IERR)
2721         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2722      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2723      &   FG_COMM1,IERR)
2724         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2725      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2726      &   FG_COMM1,IERR)
2727         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2728      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2729      &   FG_COMM1,IERR)
2730         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2731      &   ivec_count(fg_rank1),
2732      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2733      &   FG_COMM1,IERR)
2734         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2735      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2736      &   FG_COMM1,IERR)
2737        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2738      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2739      &   FG_COMM1,IERR)
2740         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2741      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2742      &   FG_COMM1,IERR)
2743        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2744      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2745      &   FG_COMM1,IERR)
2746         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2747      &   ivec_count(fg_rank1),
2748      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2749      &   FG_COMM1,IERR)
2750         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2751      &   ivec_count(fg_rank1),
2752      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2753      &   FG_COMM1,IERR)
2754         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2755      &   ivec_count(fg_rank1),
2756      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2757      &   MPI_MAT2,FG_COMM1,IERR)
2758         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2759      &   ivec_count(fg_rank1),
2760      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2761      &   MPI_MAT2,FG_COMM1,IERR)
2762         endif
2763 #else
2764 c Passes matrix info through the ring
2765       isend=fg_rank1
2766       irecv=fg_rank1-1
2767       if (irecv.lt.0) irecv=nfgtasks1-1
2768       iprev=irecv
2769       inext=fg_rank1+1
2770       if (inext.ge.nfgtasks1) inext=0
2771       do i=1,nfgtasks1-1
2772 c        write (iout,*) "isend",isend," irecv",irecv
2773 c        call flush(iout)
2774         lensend=lentyp(isend)
2775         lenrecv=lentyp(irecv)
2776 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2777 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2778 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2779 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2780 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2781 c        write (iout,*) "Gather ROTAT1"
2782 c        call flush(iout)
2783 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2784 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2785 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2786 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2787 c        write (iout,*) "Gather ROTAT2"
2788 c        call flush(iout)
2789         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2790      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2791      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2792      &   iprev,4400+irecv,FG_COMM,status,IERR)
2793 c        write (iout,*) "Gather ROTAT_OLD"
2794 c        call flush(iout)
2795         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2796      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2797      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2798      &   iprev,5500+irecv,FG_COMM,status,IERR)
2799 c        write (iout,*) "Gather PRECOMP11"
2800 c        call flush(iout)
2801         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2802      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2803      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2804      &   iprev,6600+irecv,FG_COMM,status,IERR)
2805 c        write (iout,*) "Gather PRECOMP12"
2806 c        call flush(iout)
2807         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2808      &  then
2809         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2810      &   MPI_ROTAT2(lensend),inext,7700+isend,
2811      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2812      &   iprev,7700+irecv,FG_COMM,status,IERR)
2813 c        write (iout,*) "Gather PRECOMP21"
2814 c        call flush(iout)
2815         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2816      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2817      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2818      &   iprev,8800+irecv,FG_COMM,status,IERR)
2819 c        write (iout,*) "Gather PRECOMP22"
2820 c        call flush(iout)
2821         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2822      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2823      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2824      &   MPI_PRECOMP23(lenrecv),
2825      &   iprev,9900+irecv,FG_COMM,status,IERR)
2826 c        write (iout,*) "Gather PRECOMP23"
2827 c        call flush(iout)
2828         endif
2829         isend=irecv
2830         irecv=irecv-1
2831         if (irecv.lt.0) irecv=nfgtasks1-1
2832       enddo
2833 #endif
2834         time_gather=time_gather+MPI_Wtime()-time00
2835       endif
2836 #ifdef DEBUG
2837 c      if (fg_rank.eq.0) then
2838         write (iout,*) "Arrays UG and UGDER"
2839         do i=1,nres-1
2840           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2841      &     ((ug(l,k,i),l=1,2),k=1,2),
2842      &     ((ugder(l,k,i),l=1,2),k=1,2)
2843         enddo
2844         write (iout,*) "Arrays UG2 and UG2DER"
2845         do i=1,nres-1
2846           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2847      &     ((ug2(l,k,i),l=1,2),k=1,2),
2848      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2849         enddo
2850         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2851         do i=1,nres-1
2852           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2853      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2854      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2855         enddo
2856         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2857         do i=1,nres-1
2858           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2859      &     costab(i),sintab(i),costab2(i),sintab2(i)
2860         enddo
2861         write (iout,*) "Array MUDER"
2862         do i=1,nres-1
2863           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2864         enddo
2865 c      endif
2866 #endif
2867 #endif
2868 cd      do i=1,nres
2869 cd        iti = itortyp(itype(i))
2870 cd        write (iout,*) i
2871 cd        do j=1,2
2872 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2873 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2874 cd        enddo
2875 cd      enddo
2876       return
2877       end
2878 C--------------------------------------------------------------------------
2879       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2880 C
2881 C This subroutine calculates the average interaction energy and its gradient
2882 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2883 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2884 C The potential depends both on the distance of peptide-group centers and on
2885 C the orientation of the CA-CA virtual bonds.
2886 C
2887       implicit real*8 (a-h,o-z)
2888 #ifdef MPI
2889       include 'mpif.h'
2890 #endif
2891       include 'DIMENSIONS'
2892       include 'COMMON.CONTROL'
2893       include 'COMMON.SETUP'
2894       include 'COMMON.IOUNITS'
2895       include 'COMMON.GEO'
2896       include 'COMMON.VAR'
2897       include 'COMMON.LOCAL'
2898       include 'COMMON.CHAIN'
2899       include 'COMMON.DERIV'
2900       include 'COMMON.INTERACT'
2901       include 'COMMON.CONTACTS'
2902       include 'COMMON.TORSION'
2903       include 'COMMON.VECTORS'
2904       include 'COMMON.FFIELD'
2905       include 'COMMON.TIME1'
2906       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2907      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2908       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2909      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2910       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2911      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2912      &    num_conti,j1,j2
2913 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2914 #ifdef MOMENT
2915       double precision scal_el /1.0d0/
2916 #else
2917       double precision scal_el /0.5d0/
2918 #endif
2919 C 12/13/98
2920 C 13-go grudnia roku pamietnego...
2921       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2922      &                   0.0d0,1.0d0,0.0d0,
2923      &                   0.0d0,0.0d0,1.0d0/
2924 cd      write(iout,*) 'In EELEC'
2925 cd      do i=1,nloctyp
2926 cd        write(iout,*) 'Type',i
2927 cd        write(iout,*) 'B1',B1(:,i)
2928 cd        write(iout,*) 'B2',B2(:,i)
2929 cd        write(iout,*) 'CC',CC(:,:,i)
2930 cd        write(iout,*) 'DD',DD(:,:,i)
2931 cd        write(iout,*) 'EE',EE(:,:,i)
2932 cd      enddo
2933 cd      call check_vecgrad
2934 cd      stop
2935       if (icheckgrad.eq.1) then
2936         do i=1,nres-1
2937           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2938           do k=1,3
2939             dc_norm(k,i)=dc(k,i)*fac
2940           enddo
2941 c          write (iout,*) 'i',i,' fac',fac
2942         enddo
2943       endif
2944       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2945      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2946      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2947 c        call vec_and_deriv
2948 #ifdef TIMING
2949         time01=MPI_Wtime()
2950 #endif
2951         call set_matrices
2952 #ifdef TIMING
2953         time_mat=time_mat+MPI_Wtime()-time01
2954 #endif
2955       endif
2956 cd      do i=1,nres-1
2957 cd        write (iout,*) 'i=',i
2958 cd        do k=1,3
2959 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2960 cd        enddo
2961 cd        do k=1,3
2962 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2963 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2964 cd        enddo
2965 cd      enddo
2966       t_eelecij=0.0d0
2967       ees=0.0D0
2968       evdw1=0.0D0
2969       eel_loc=0.0d0
2970       eello_turn3=0.0d0
2971       eello_turn4=0.0d0
2972       ind=0
2973       do i=1,nres
2974         num_cont_hb(i)=0
2975       enddo
2976 cd      print '(a)','Enter EELEC'
2977 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2978       do i=1,nres
2979         gel_loc_loc(i)=0.0d0
2980         gcorr_loc(i)=0.0d0
2981       enddo
2982 c
2983 c
2984 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2985 C
2986 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2987 C
2988       do i=iturn3_start,iturn3_end
2989         dxi=dc(1,i)
2990         dyi=dc(2,i)
2991         dzi=dc(3,i)
2992         dx_normi=dc_norm(1,i)
2993         dy_normi=dc_norm(2,i)
2994         dz_normi=dc_norm(3,i)
2995         xmedi=c(1,i)+0.5d0*dxi
2996         ymedi=c(2,i)+0.5d0*dyi
2997         zmedi=c(3,i)+0.5d0*dzi
2998         num_conti=0
2999         call eelecij(i,i+2,ees,evdw1,eel_loc)
3000         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3001         num_cont_hb(i)=num_conti
3002       enddo
3003       do i=iturn4_start,iturn4_end
3004         dxi=dc(1,i)
3005         dyi=dc(2,i)
3006         dzi=dc(3,i)
3007         dx_normi=dc_norm(1,i)
3008         dy_normi=dc_norm(2,i)
3009         dz_normi=dc_norm(3,i)
3010         xmedi=c(1,i)+0.5d0*dxi
3011         ymedi=c(2,i)+0.5d0*dyi
3012         zmedi=c(3,i)+0.5d0*dzi
3013         num_conti=num_cont_hb(i)
3014         call eelecij(i,i+3,ees,evdw1,eel_loc)
3015         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3016         num_cont_hb(i)=num_conti
3017       enddo   ! i
3018 c
3019 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3020 c
3021       do i=iatel_s,iatel_e
3022         dxi=dc(1,i)
3023         dyi=dc(2,i)
3024         dzi=dc(3,i)
3025         dx_normi=dc_norm(1,i)
3026         dy_normi=dc_norm(2,i)
3027         dz_normi=dc_norm(3,i)
3028         xmedi=c(1,i)+0.5d0*dxi
3029         ymedi=c(2,i)+0.5d0*dyi
3030         zmedi=c(3,i)+0.5d0*dzi
3031 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3032         num_conti=num_cont_hb(i)
3033         do j=ielstart(i),ielend(i)
3034           call eelecij(i,j,ees,evdw1,eel_loc)
3035         enddo ! j
3036         num_cont_hb(i)=num_conti
3037       enddo   ! i
3038 c      write (iout,*) "Number of loop steps in EELEC:",ind
3039 cd      do i=1,nres
3040 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3041 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3042 cd      enddo
3043 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3044 ccc      eel_loc=eel_loc+eello_turn3
3045 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3046       return
3047       end
3048 C-------------------------------------------------------------------------------
3049       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3050       implicit real*8 (a-h,o-z)
3051       include 'DIMENSIONS'
3052 #ifdef MPI
3053       include "mpif.h"
3054 #endif
3055       include 'COMMON.CONTROL'
3056       include 'COMMON.IOUNITS'
3057       include 'COMMON.GEO'
3058       include 'COMMON.VAR'
3059       include 'COMMON.LOCAL'
3060       include 'COMMON.CHAIN'
3061       include 'COMMON.DERIV'
3062       include 'COMMON.INTERACT'
3063       include 'COMMON.CONTACTS'
3064       include 'COMMON.TORSION'
3065       include 'COMMON.VECTORS'
3066       include 'COMMON.FFIELD'
3067       include 'COMMON.TIME1'
3068       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3069      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3070       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3071      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3072       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3073      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3074      &    num_conti,j1,j2
3075 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3076 #ifdef MOMENT
3077       double precision scal_el /1.0d0/
3078 #else
3079       double precision scal_el /0.5d0/
3080 #endif
3081 C 12/13/98
3082 C 13-go grudnia roku pamietnego...
3083       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3084      &                   0.0d0,1.0d0,0.0d0,
3085      &                   0.0d0,0.0d0,1.0d0/
3086 c          time00=MPI_Wtime()
3087 cd      write (iout,*) "eelecij",i,j
3088 c          ind=ind+1
3089           iteli=itel(i)
3090           itelj=itel(j)
3091           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3092           aaa=app(iteli,itelj)
3093           bbb=bpp(iteli,itelj)
3094           ael6i=ael6(iteli,itelj)
3095           ael3i=ael3(iteli,itelj)
3096           dxj=dc(1,j)
3097           dyj=dc(2,j)
3098           dzj=dc(3,j)
3099           dx_normj=dc_norm(1,j)
3100           dy_normj=dc_norm(2,j)
3101           dz_normj=dc_norm(3,j)
3102           xj=c(1,j)+0.5D0*dxj-xmedi
3103           yj=c(2,j)+0.5D0*dyj-ymedi
3104           zj=c(3,j)+0.5D0*dzj-zmedi
3105           rij=xj*xj+yj*yj+zj*zj
3106           rrmij=1.0D0/rij
3107           rij=dsqrt(rij)
3108           rmij=1.0D0/rij
3109           r3ij=rrmij*rmij
3110           r6ij=r3ij*r3ij
3111           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3112           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3113           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3114           fac=cosa-3.0D0*cosb*cosg
3115           ev1=aaa*r6ij*r6ij
3116 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3117           if (j.eq.i+2) ev1=scal_el*ev1
3118           ev2=bbb*r6ij
3119           fac3=ael6i*r6ij
3120           fac4=ael3i*r3ij
3121           evdwij=ev1+ev2
3122           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3123           el2=fac4*fac
3124           eesij=el1+el2
3125 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3126           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3127           ees=ees+eesij
3128           evdw1=evdw1+evdwij
3129 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3130 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3131 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3132 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3133
3134           if (energy_dec) then
3135               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3136               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3137           endif
3138
3139 C
3140 C Calculate contributions to the Cartesian gradient.
3141 C
3142 #ifdef SPLITELE
3143           facvdw=-6*rrmij*(ev1+evdwij)
3144           facel=-3*rrmij*(el1+eesij)
3145           fac1=fac
3146           erij(1)=xj*rmij
3147           erij(2)=yj*rmij
3148           erij(3)=zj*rmij
3149 *
3150 * Radial derivatives. First process both termini of the fragment (i,j)
3151 *
3152           ggg(1)=facel*xj
3153           ggg(2)=facel*yj
3154           ggg(3)=facel*zj
3155 c          do k=1,3
3156 c            ghalf=0.5D0*ggg(k)
3157 c            gelc(k,i)=gelc(k,i)+ghalf
3158 c            gelc(k,j)=gelc(k,j)+ghalf
3159 c          enddo
3160 c 9/28/08 AL Gradient compotents will be summed only at the end
3161           do k=1,3
3162             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3163             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3164           enddo
3165 *
3166 * Loop over residues i+1 thru j-1.
3167 *
3168 cgrad          do k=i+1,j-1
3169 cgrad            do l=1,3
3170 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3171 cgrad            enddo
3172 cgrad          enddo
3173           ggg(1)=facvdw*xj
3174           ggg(2)=facvdw*yj
3175           ggg(3)=facvdw*zj
3176 c          do k=1,3
3177 c            ghalf=0.5D0*ggg(k)
3178 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3179 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3180 c          enddo
3181 c 9/28/08 AL Gradient compotents will be summed only at the end
3182           do k=1,3
3183             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3184             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3185           enddo
3186 *
3187 * Loop over residues i+1 thru j-1.
3188 *
3189 cgrad          do k=i+1,j-1
3190 cgrad            do l=1,3
3191 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3192 cgrad            enddo
3193 cgrad          enddo
3194 #else
3195           facvdw=ev1+evdwij
3196           facel=el1+eesij
3197           fac1=fac
3198           fac=-3*rrmij*(facvdw+facvdw+facel)
3199           erij(1)=xj*rmij
3200           erij(2)=yj*rmij
3201           erij(3)=zj*rmij
3202 *
3203 * Radial derivatives. First process both termini of the fragment (i,j)
3204 *
3205           ggg(1)=fac*xj
3206           ggg(2)=fac*yj
3207           ggg(3)=fac*zj
3208 c          do k=1,3
3209 c            ghalf=0.5D0*ggg(k)
3210 c            gelc(k,i)=gelc(k,i)+ghalf
3211 c            gelc(k,j)=gelc(k,j)+ghalf
3212 c          enddo
3213 c 9/28/08 AL Gradient compotents will be summed only at the end
3214           do k=1,3
3215             gelc_long(k,j)=gelc(k,j)+ggg(k)
3216             gelc_long(k,i)=gelc(k,i)-ggg(k)
3217           enddo
3218 *
3219 * Loop over residues i+1 thru j-1.
3220 *
3221 cgrad          do k=i+1,j-1
3222 cgrad            do l=1,3
3223 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3224 cgrad            enddo
3225 cgrad          enddo
3226 c 9/28/08 AL Gradient compotents will be summed only at the end
3227           ggg(1)=facvdw*xj
3228           ggg(2)=facvdw*yj
3229           ggg(3)=facvdw*zj
3230           do k=1,3
3231             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3232             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3233           enddo
3234 #endif
3235 *
3236 * Angular part
3237 *
3238           ecosa=2.0D0*fac3*fac1+fac4
3239           fac4=-3.0D0*fac4
3240           fac3=-6.0D0*fac3
3241           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3242           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3243           do k=1,3
3244             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3245             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3246           enddo
3247 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3248 cd   &          (dcosg(k),k=1,3)
3249           do k=1,3
3250             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3251           enddo
3252 c          do k=1,3
3253 c            ghalf=0.5D0*ggg(k)
3254 c            gelc(k,i)=gelc(k,i)+ghalf
3255 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3256 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3257 c            gelc(k,j)=gelc(k,j)+ghalf
3258 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3259 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3260 c          enddo
3261 cgrad          do k=i+1,j-1
3262 cgrad            do l=1,3
3263 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3264 cgrad            enddo
3265 cgrad          enddo
3266           do k=1,3
3267             gelc(k,i)=gelc(k,i)
3268      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3269      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3270             gelc(k,j)=gelc(k,j)
3271      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3272      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3273             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3274             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3275           enddo
3276           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3277      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3278      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3279 C
3280 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3281 C   energy of a peptide unit is assumed in the form of a second-order
3282 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3283 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3284 C   are computed for EVERY pair of non-contiguous peptide groups.
3285 C
3286           if (j.lt.nres-1) then
3287             j1=j+1
3288             j2=j-1
3289           else
3290             j1=j-1
3291             j2=j-2
3292           endif
3293           kkk=0
3294           do k=1,2
3295             do l=1,2
3296               kkk=kkk+1
3297               muij(kkk)=mu(k,i)*mu(l,j)
3298             enddo
3299           enddo
3300 cd         write (iout,*) 'EELEC: i',i,' j',j
3301 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3302 cd          write(iout,*) 'muij',muij
3303           ury=scalar(uy(1,i),erij)
3304           urz=scalar(uz(1,i),erij)
3305           vry=scalar(uy(1,j),erij)
3306           vrz=scalar(uz(1,j),erij)
3307           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3308           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3309           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3310           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3311           fac=dsqrt(-ael6i)*r3ij
3312           a22=a22*fac
3313           a23=a23*fac
3314           a32=a32*fac
3315           a33=a33*fac
3316 cd          write (iout,'(4i5,4f10.5)')
3317 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3318 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3319 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3320 cd     &      uy(:,j),uz(:,j)
3321 cd          write (iout,'(4f10.5)')
3322 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3323 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3324 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3325 cd           write (iout,'(9f10.5/)')
3326 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3327 C Derivatives of the elements of A in virtual-bond vectors
3328           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3329           do k=1,3
3330             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3331             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3332             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3333             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3334             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3335             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3336             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3337             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3338             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3339             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3340             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3341             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3342           enddo
3343 C Compute radial contributions to the gradient
3344           facr=-3.0d0*rrmij
3345           a22der=a22*facr
3346           a23der=a23*facr
3347           a32der=a32*facr
3348           a33der=a33*facr
3349           agg(1,1)=a22der*xj
3350           agg(2,1)=a22der*yj
3351           agg(3,1)=a22der*zj
3352           agg(1,2)=a23der*xj
3353           agg(2,2)=a23der*yj
3354           agg(3,2)=a23der*zj
3355           agg(1,3)=a32der*xj
3356           agg(2,3)=a32der*yj
3357           agg(3,3)=a32der*zj
3358           agg(1,4)=a33der*xj
3359           agg(2,4)=a33der*yj
3360           agg(3,4)=a33der*zj
3361 C Add the contributions coming from er
3362           fac3=-3.0d0*fac
3363           do k=1,3
3364             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3365             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3366             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3367             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3368           enddo
3369           do k=1,3
3370 C Derivatives in DC(i)
3371 cgrad            ghalf1=0.5d0*agg(k,1)
3372 cgrad            ghalf2=0.5d0*agg(k,2)
3373 cgrad            ghalf3=0.5d0*agg(k,3)
3374 cgrad            ghalf4=0.5d0*agg(k,4)
3375             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3376      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3377             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3378      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3379             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3380      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3381             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3382      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3383 C Derivatives in DC(i+1)
3384             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3385      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3386             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3387      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3388             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3389      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3390             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3391      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3392 C Derivatives in DC(j)
3393             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3394      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3395             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3396      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3397             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3398      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3399             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3400      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3401 C Derivatives in DC(j+1) or DC(nres-1)
3402             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3403      &      -3.0d0*vryg(k,3)*ury)
3404             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3405      &      -3.0d0*vrzg(k,3)*ury)
3406             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3407      &      -3.0d0*vryg(k,3)*urz)
3408             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3409      &      -3.0d0*vrzg(k,3)*urz)
3410 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3411 cgrad              do l=1,4
3412 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3413 cgrad              enddo
3414 cgrad            endif
3415           enddo
3416           acipa(1,1)=a22
3417           acipa(1,2)=a23
3418           acipa(2,1)=a32
3419           acipa(2,2)=a33
3420           a22=-a22
3421           a23=-a23
3422           do l=1,2
3423             do k=1,3
3424               agg(k,l)=-agg(k,l)
3425               aggi(k,l)=-aggi(k,l)
3426               aggi1(k,l)=-aggi1(k,l)
3427               aggj(k,l)=-aggj(k,l)
3428               aggj1(k,l)=-aggj1(k,l)
3429             enddo
3430           enddo
3431           if (j.lt.nres-1) then
3432             a22=-a22
3433             a32=-a32
3434             do l=1,3,2
3435               do k=1,3
3436                 agg(k,l)=-agg(k,l)
3437                 aggi(k,l)=-aggi(k,l)
3438                 aggi1(k,l)=-aggi1(k,l)
3439                 aggj(k,l)=-aggj(k,l)
3440                 aggj1(k,l)=-aggj1(k,l)
3441               enddo
3442             enddo
3443           else
3444             a22=-a22
3445             a23=-a23
3446             a32=-a32
3447             a33=-a33
3448             do l=1,4
3449               do k=1,3
3450                 agg(k,l)=-agg(k,l)
3451                 aggi(k,l)=-aggi(k,l)
3452                 aggi1(k,l)=-aggi1(k,l)
3453                 aggj(k,l)=-aggj(k,l)
3454                 aggj1(k,l)=-aggj1(k,l)
3455               enddo
3456             enddo
3457           endif
3458           ENDIF ! WCORR
3459           IF (wel_loc.gt.0.0d0) THEN
3460 C Contribution to the local-electrostatic energy coming from the i-j pair
3461           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3462      &     +a33*muij(4)
3463 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3464
3465           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3466      &            'eelloc',i,j,eel_loc_ij
3467
3468           eel_loc=eel_loc+eel_loc_ij
3469 C Partial derivatives in virtual-bond dihedral angles gamma
3470           if (i.gt.1)
3471      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3472      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3473      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3474           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3475      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3476      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3477 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3478           do l=1,3
3479             ggg(l)=agg(l,1)*muij(1)+
3480      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3481             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3482             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3483 cgrad            ghalf=0.5d0*ggg(l)
3484 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3485 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3486           enddo
3487 cgrad          do k=i+1,j2
3488 cgrad            do l=1,3
3489 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3490 cgrad            enddo
3491 cgrad          enddo
3492 C Remaining derivatives of eello
3493           do l=1,3
3494             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3495      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3496             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3497      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3498             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3499      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3500             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3501      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3502           enddo
3503           ENDIF
3504 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3505 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3506           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3507      &       .and. num_conti.le.maxconts) then
3508 c            write (iout,*) i,j," entered corr"
3509 C
3510 C Calculate the contact function. The ith column of the array JCONT will
3511 C contain the numbers of atoms that make contacts with the atom I (of numbers
3512 C greater than I). The arrays FACONT and GACONT will contain the values of
3513 C the contact function and its derivative.
3514 c           r0ij=1.02D0*rpp(iteli,itelj)
3515 c           r0ij=1.11D0*rpp(iteli,itelj)
3516             r0ij=2.20D0*rpp(iteli,itelj)
3517 c           r0ij=1.55D0*rpp(iteli,itelj)
3518             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3519             if (fcont.gt.0.0D0) then
3520               num_conti=num_conti+1
3521               if (num_conti.gt.maxconts) then
3522                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3523      &                         ' will skip next contacts for this conf.'
3524               else
3525                 jcont_hb(num_conti,i)=j
3526 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3527 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3528                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3529      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3530 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3531 C  terms.
3532                 d_cont(num_conti,i)=rij
3533 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3534 C     --- Electrostatic-interaction matrix ---
3535                 a_chuj(1,1,num_conti,i)=a22
3536                 a_chuj(1,2,num_conti,i)=a23
3537                 a_chuj(2,1,num_conti,i)=a32
3538                 a_chuj(2,2,num_conti,i)=a33
3539 C     --- Gradient of rij
3540                 do kkk=1,3
3541                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3542                 enddo
3543                 kkll=0
3544                 do k=1,2
3545                   do l=1,2
3546                     kkll=kkll+1
3547                     do m=1,3
3548                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3549                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3550                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3551                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3552                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3553                     enddo
3554                   enddo
3555                 enddo
3556                 ENDIF
3557                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3558 C Calculate contact energies
3559                 cosa4=4.0D0*cosa
3560                 wij=cosa-3.0D0*cosb*cosg
3561                 cosbg1=cosb+cosg
3562                 cosbg2=cosb-cosg
3563 c               fac3=dsqrt(-ael6i)/r0ij**3
3564                 fac3=dsqrt(-ael6i)*r3ij
3565 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3566                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3567                 if (ees0tmp.gt.0) then
3568                   ees0pij=dsqrt(ees0tmp)
3569                 else
3570                   ees0pij=0
3571                 endif
3572 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3573                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3574                 if (ees0tmp.gt.0) then
3575                   ees0mij=dsqrt(ees0tmp)
3576                 else
3577                   ees0mij=0
3578                 endif
3579 c               ees0mij=0.0D0
3580                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3581                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3582 C Diagnostics. Comment out or remove after debugging!
3583 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3584 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3585 c               ees0m(num_conti,i)=0.0D0
3586 C End diagnostics.
3587 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3588 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3589 C Angular derivatives of the contact function
3590                 ees0pij1=fac3/ees0pij
3591                 ees0mij1=fac3/ees0mij
3592                 fac3p=-3.0D0*fac3*rrmij
3593                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3594                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3595 c               ees0mij1=0.0D0
3596                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3597                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3598                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3599                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3600                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3601                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3602                 ecosap=ecosa1+ecosa2
3603                 ecosbp=ecosb1+ecosb2
3604                 ecosgp=ecosg1+ecosg2
3605                 ecosam=ecosa1-ecosa2
3606                 ecosbm=ecosb1-ecosb2
3607                 ecosgm=ecosg1-ecosg2
3608 C Diagnostics
3609 c               ecosap=ecosa1
3610 c               ecosbp=ecosb1
3611 c               ecosgp=ecosg1
3612 c               ecosam=0.0D0
3613 c               ecosbm=0.0D0
3614 c               ecosgm=0.0D0
3615 C End diagnostics
3616                 facont_hb(num_conti,i)=fcont
3617                 fprimcont=fprimcont/rij
3618 cd              facont_hb(num_conti,i)=1.0D0
3619 C Following line is for diagnostics.
3620 cd              fprimcont=0.0D0
3621                 do k=1,3
3622                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3623                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3624                 enddo
3625                 do k=1,3
3626                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3627                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3628                 enddo
3629                 gggp(1)=gggp(1)+ees0pijp*xj
3630                 gggp(2)=gggp(2)+ees0pijp*yj
3631                 gggp(3)=gggp(3)+ees0pijp*zj
3632                 gggm(1)=gggm(1)+ees0mijp*xj
3633                 gggm(2)=gggm(2)+ees0mijp*yj
3634                 gggm(3)=gggm(3)+ees0mijp*zj
3635 C Derivatives due to the contact function
3636                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3637                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3638                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3639                 do k=1,3
3640 c
3641 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3642 c          following the change of gradient-summation algorithm.
3643 c
3644 cgrad                  ghalfp=0.5D0*gggp(k)
3645 cgrad                  ghalfm=0.5D0*gggm(k)
3646                   gacontp_hb1(k,num_conti,i)=!ghalfp
3647      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3648      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3649                   gacontp_hb2(k,num_conti,i)=!ghalfp
3650      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3651      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3652                   gacontp_hb3(k,num_conti,i)=gggp(k)
3653                   gacontm_hb1(k,num_conti,i)=!ghalfm
3654      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3655      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3656                   gacontm_hb2(k,num_conti,i)=!ghalfm
3657      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3658      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3659                   gacontm_hb3(k,num_conti,i)=gggm(k)
3660                 enddo
3661 C Diagnostics. Comment out or remove after debugging!
3662 cdiag           do k=1,3
3663 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3664 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3665 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3666 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3667 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3668 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3669 cdiag           enddo
3670               ENDIF ! wcorr
3671               endif  ! num_conti.le.maxconts
3672             endif  ! fcont.gt.0
3673           endif    ! j.gt.i+1
3674           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3675             do k=1,4
3676               do l=1,3
3677                 ghalf=0.5d0*agg(l,k)
3678                 aggi(l,k)=aggi(l,k)+ghalf
3679                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3680                 aggj(l,k)=aggj(l,k)+ghalf
3681               enddo
3682             enddo
3683             if (j.eq.nres-1 .and. i.lt.j-2) then
3684               do k=1,4
3685                 do l=1,3
3686                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3687                 enddo
3688               enddo
3689             endif
3690           endif
3691 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3692       return
3693       end
3694 C-----------------------------------------------------------------------------
3695       subroutine eturn3(i,eello_turn3)
3696 C Third- and fourth-order contributions from turns
3697       implicit real*8 (a-h,o-z)
3698       include 'DIMENSIONS'
3699       include 'COMMON.IOUNITS'
3700       include 'COMMON.GEO'
3701       include 'COMMON.VAR'
3702       include 'COMMON.LOCAL'
3703       include 'COMMON.CHAIN'
3704       include 'COMMON.DERIV'
3705       include 'COMMON.INTERACT'
3706       include 'COMMON.CONTACTS'
3707       include 'COMMON.TORSION'
3708       include 'COMMON.VECTORS'
3709       include 'COMMON.FFIELD'
3710       include 'COMMON.CONTROL'
3711       dimension ggg(3)
3712       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3713      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3714      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3715       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3716      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3717       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3718      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3719      &    num_conti,j1,j2
3720       j=i+2
3721 c      write (iout,*) "eturn3",i,j,j1,j2
3722       a_temp(1,1)=a22
3723       a_temp(1,2)=a23
3724       a_temp(2,1)=a32
3725       a_temp(2,2)=a33
3726 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3727 C
3728 C               Third-order contributions
3729 C
3730 C                 (i+2)o----(i+3)
3731 C                      | |
3732 C                      | |
3733 C                 (i+1)o----i
3734 C
3735 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3736 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3737         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3738         call transpose2(auxmat(1,1),auxmat1(1,1))
3739         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3740         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3741         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3742      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3743 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3744 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3745 cd     &    ' eello_turn3_num',4*eello_turn3_num
3746 C Derivatives in gamma(i)
3747         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3748         call transpose2(auxmat2(1,1),auxmat3(1,1))
3749         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3750         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3751 C Derivatives in gamma(i+1)
3752         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3753         call transpose2(auxmat2(1,1),auxmat3(1,1))
3754         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3755         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3756      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3757 C Cartesian derivatives
3758         do l=1,3
3759 c            ghalf1=0.5d0*agg(l,1)
3760 c            ghalf2=0.5d0*agg(l,2)
3761 c            ghalf3=0.5d0*agg(l,3)
3762 c            ghalf4=0.5d0*agg(l,4)
3763           a_temp(1,1)=aggi(l,1)!+ghalf1
3764           a_temp(1,2)=aggi(l,2)!+ghalf2
3765           a_temp(2,1)=aggi(l,3)!+ghalf3
3766           a_temp(2,2)=aggi(l,4)!+ghalf4
3767           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3768           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3769      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3770           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3771           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3772           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3773           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3774           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3775           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3776      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3777           a_temp(1,1)=aggj(l,1)!+ghalf1
3778           a_temp(1,2)=aggj(l,2)!+ghalf2
3779           a_temp(2,1)=aggj(l,3)!+ghalf3
3780           a_temp(2,2)=aggj(l,4)!+ghalf4
3781           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3782           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3783      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3784           a_temp(1,1)=aggj1(l,1)
3785           a_temp(1,2)=aggj1(l,2)
3786           a_temp(2,1)=aggj1(l,3)
3787           a_temp(2,2)=aggj1(l,4)
3788           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3789           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3790      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3791         enddo
3792       return
3793       end
3794 C-------------------------------------------------------------------------------
3795       subroutine eturn4(i,eello_turn4)
3796 C Third- and fourth-order contributions from turns
3797       implicit real*8 (a-h,o-z)
3798       include 'DIMENSIONS'
3799       include 'COMMON.IOUNITS'
3800       include 'COMMON.GEO'
3801       include 'COMMON.VAR'
3802       include 'COMMON.LOCAL'
3803       include 'COMMON.CHAIN'
3804       include 'COMMON.DERIV'
3805       include 'COMMON.INTERACT'
3806       include 'COMMON.CONTACTS'
3807       include 'COMMON.TORSION'
3808       include 'COMMON.VECTORS'
3809       include 'COMMON.FFIELD'
3810       include 'COMMON.CONTROL'
3811       dimension ggg(3)
3812       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3813      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3814      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3815       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3816      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3817       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3818      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3819      &    num_conti,j1,j2
3820       j=i+3
3821 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3822 C
3823 C               Fourth-order contributions
3824 C
3825 C                 (i+3)o----(i+4)
3826 C                     /  |
3827 C               (i+2)o   |
3828 C                     \  |
3829 C                 (i+1)o----i
3830 C
3831 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3832 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3833 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3834         a_temp(1,1)=a22
3835         a_temp(1,2)=a23
3836         a_temp(2,1)=a32
3837         a_temp(2,2)=a33
3838         iti1=itortyp(itype(i+1))
3839         iti2=itortyp(itype(i+2))
3840         iti3=itortyp(itype(i+3))
3841 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3842         call transpose2(EUg(1,1,i+1),e1t(1,1))
3843         call transpose2(Eug(1,1,i+2),e2t(1,1))
3844         call transpose2(Eug(1,1,i+3),e3t(1,1))
3845         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3846         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3847         s1=scalar2(b1(1,iti2),auxvec(1))
3848         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3849         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3850         s2=scalar2(b1(1,iti1),auxvec(1))
3851         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3852         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3853         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3854         eello_turn4=eello_turn4-(s1+s2+s3)
3855         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3856      &      'eturn4',i,j,-(s1+s2+s3)
3857 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3858 cd     &    ' eello_turn4_num',8*eello_turn4_num
3859 C Derivatives in gamma(i)
3860         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3861         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3862         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3863         s1=scalar2(b1(1,iti2),auxvec(1))
3864         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3865         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3866         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3867 C Derivatives in gamma(i+1)
3868         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3869         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3870         s2=scalar2(b1(1,iti1),auxvec(1))
3871         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3872         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3873         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3874         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3875 C Derivatives in gamma(i+2)
3876         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3877         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3878         s1=scalar2(b1(1,iti2),auxvec(1))
3879         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3880         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3881         s2=scalar2(b1(1,iti1),auxvec(1))
3882         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3883         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3884         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3885         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3886 C Cartesian derivatives
3887 C Derivatives of this turn contributions in DC(i+2)
3888         if (j.lt.nres-1) then
3889           do l=1,3
3890             a_temp(1,1)=agg(l,1)
3891             a_temp(1,2)=agg(l,2)
3892             a_temp(2,1)=agg(l,3)
3893             a_temp(2,2)=agg(l,4)
3894             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3895             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3896             s1=scalar2(b1(1,iti2),auxvec(1))
3897             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3898             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3899             s2=scalar2(b1(1,iti1),auxvec(1))
3900             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3901             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3902             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3903             ggg(l)=-(s1+s2+s3)
3904             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3905           enddo
3906         endif
3907 C Remaining derivatives of this turn contribution
3908         do l=1,3
3909           a_temp(1,1)=aggi(l,1)
3910           a_temp(1,2)=aggi(l,2)
3911           a_temp(2,1)=aggi(l,3)
3912           a_temp(2,2)=aggi(l,4)
3913           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3914           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3915           s1=scalar2(b1(1,iti2),auxvec(1))
3916           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3917           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3918           s2=scalar2(b1(1,iti1),auxvec(1))
3919           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3920           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3921           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3922           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3923           a_temp(1,1)=aggi1(l,1)
3924           a_temp(1,2)=aggi1(l,2)
3925           a_temp(2,1)=aggi1(l,3)
3926           a_temp(2,2)=aggi1(l,4)
3927           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3928           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3929           s1=scalar2(b1(1,iti2),auxvec(1))
3930           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3931           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3932           s2=scalar2(b1(1,iti1),auxvec(1))
3933           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3934           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3935           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3936           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3937           a_temp(1,1)=aggj(l,1)
3938           a_temp(1,2)=aggj(l,2)
3939           a_temp(2,1)=aggj(l,3)
3940           a_temp(2,2)=aggj(l,4)
3941           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3942           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3943           s1=scalar2(b1(1,iti2),auxvec(1))
3944           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3945           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3946           s2=scalar2(b1(1,iti1),auxvec(1))
3947           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3948           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3949           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3950           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3951           a_temp(1,1)=aggj1(l,1)
3952           a_temp(1,2)=aggj1(l,2)
3953           a_temp(2,1)=aggj1(l,3)
3954           a_temp(2,2)=aggj1(l,4)
3955           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3956           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3957           s1=scalar2(b1(1,iti2),auxvec(1))
3958           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3959           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3960           s2=scalar2(b1(1,iti1),auxvec(1))
3961           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3962           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3963           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3964 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3965           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3966         enddo
3967       return
3968       end
3969 C-----------------------------------------------------------------------------
3970       subroutine vecpr(u,v,w)
3971       implicit real*8(a-h,o-z)
3972       dimension u(3),v(3),w(3)
3973       w(1)=u(2)*v(3)-u(3)*v(2)
3974       w(2)=-u(1)*v(3)+u(3)*v(1)
3975       w(3)=u(1)*v(2)-u(2)*v(1)
3976       return
3977       end
3978 C-----------------------------------------------------------------------------
3979       subroutine unormderiv(u,ugrad,unorm,ungrad)
3980 C This subroutine computes the derivatives of a normalized vector u, given
3981 C the derivatives computed without normalization conditions, ugrad. Returns
3982 C ungrad.
3983       implicit none
3984       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3985       double precision vec(3)
3986       double precision scalar
3987       integer i,j
3988 c      write (2,*) 'ugrad',ugrad
3989 c      write (2,*) 'u',u
3990       do i=1,3
3991         vec(i)=scalar(ugrad(1,i),u(1))
3992       enddo
3993 c      write (2,*) 'vec',vec
3994       do i=1,3
3995         do j=1,3
3996           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3997         enddo
3998       enddo
3999 c      write (2,*) 'ungrad',ungrad
4000       return
4001       end
4002 C-----------------------------------------------------------------------------
4003       subroutine escp_soft_sphere(evdw2,evdw2_14)
4004 C
4005 C This subroutine calculates the excluded-volume interaction energy between
4006 C peptide-group centers and side chains and its gradient in virtual-bond and
4007 C side-chain vectors.
4008 C
4009       implicit real*8 (a-h,o-z)
4010       include 'DIMENSIONS'
4011       include 'COMMON.GEO'
4012       include 'COMMON.VAR'
4013       include 'COMMON.LOCAL'
4014       include 'COMMON.CHAIN'
4015       include 'COMMON.DERIV'
4016       include 'COMMON.INTERACT'
4017       include 'COMMON.FFIELD'
4018       include 'COMMON.IOUNITS'
4019       include 'COMMON.CONTROL'
4020       dimension ggg(3)
4021       evdw2=0.0D0
4022       evdw2_14=0.0d0
4023       r0_scp=4.5d0
4024 cd    print '(a)','Enter ESCP'
4025 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4026       do i=iatscp_s,iatscp_e
4027         iteli=itel(i)
4028         xi=0.5D0*(c(1,i)+c(1,i+1))
4029         yi=0.5D0*(c(2,i)+c(2,i+1))
4030         zi=0.5D0*(c(3,i)+c(3,i+1))
4031
4032         do iint=1,nscp_gr(i)
4033
4034         do j=iscpstart(i,iint),iscpend(i,iint)
4035           itypj=itype(j)
4036 C Uncomment following three lines for SC-p interactions
4037 c         xj=c(1,nres+j)-xi
4038 c         yj=c(2,nres+j)-yi
4039 c         zj=c(3,nres+j)-zi
4040 C Uncomment following three lines for Ca-p interactions
4041           xj=c(1,j)-xi
4042           yj=c(2,j)-yi
4043           zj=c(3,j)-zi
4044           rij=xj*xj+yj*yj+zj*zj
4045           r0ij=r0_scp
4046           r0ijsq=r0ij*r0ij
4047           if (rij.lt.r0ijsq) then
4048             evdwij=0.25d0*(rij-r0ijsq)**2
4049             fac=rij-r0ijsq
4050           else
4051             evdwij=0.0d0
4052             fac=0.0d0
4053           endif
4054           evdw2=evdw2+evdwij
4055 C
4056 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4057 C
4058           ggg(1)=xj*fac
4059           ggg(2)=yj*fac
4060           ggg(3)=zj*fac
4061 cgrad          if (j.lt.i) then
4062 cd          write (iout,*) 'j<i'
4063 C Uncomment following three lines for SC-p interactions
4064 c           do k=1,3
4065 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4066 c           enddo
4067 cgrad          else
4068 cd          write (iout,*) 'j>i'
4069 cgrad            do k=1,3
4070 cgrad              ggg(k)=-ggg(k)
4071 C Uncomment following line for SC-p interactions
4072 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4073 cgrad            enddo
4074 cgrad          endif
4075 cgrad          do k=1,3
4076 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4077 cgrad          enddo
4078 cgrad          kstart=min0(i+1,j)
4079 cgrad          kend=max0(i-1,j-1)
4080 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4081 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4082 cgrad          do k=kstart,kend
4083 cgrad            do l=1,3
4084 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4085 cgrad            enddo
4086 cgrad          enddo
4087           do k=1,3
4088             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4089             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4090           enddo
4091         enddo
4092
4093         enddo ! iint
4094       enddo ! i
4095       return
4096       end
4097 C-----------------------------------------------------------------------------
4098       subroutine escp(evdw2,evdw2_14)
4099 C
4100 C This subroutine calculates the excluded-volume interaction energy between
4101 C peptide-group centers and side chains and its gradient in virtual-bond and
4102 C side-chain vectors.
4103 C
4104       implicit real*8 (a-h,o-z)
4105       include 'DIMENSIONS'
4106       include 'COMMON.GEO'
4107       include 'COMMON.VAR'
4108       include 'COMMON.LOCAL'
4109       include 'COMMON.CHAIN'
4110       include 'COMMON.DERIV'
4111       include 'COMMON.INTERACT'
4112       include 'COMMON.FFIELD'
4113       include 'COMMON.IOUNITS'
4114       include 'COMMON.CONTROL'
4115       dimension ggg(3)
4116       evdw2=0.0D0
4117       evdw2_14=0.0d0
4118 cd    print '(a)','Enter ESCP'
4119 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4120       do i=iatscp_s,iatscp_e
4121         iteli=itel(i)
4122         xi=0.5D0*(c(1,i)+c(1,i+1))
4123         yi=0.5D0*(c(2,i)+c(2,i+1))
4124         zi=0.5D0*(c(3,i)+c(3,i+1))
4125
4126         do iint=1,nscp_gr(i)
4127
4128         do j=iscpstart(i,iint),iscpend(i,iint)
4129           itypj=itype(j)
4130 C Uncomment following three lines for SC-p interactions
4131 c         xj=c(1,nres+j)-xi
4132 c         yj=c(2,nres+j)-yi
4133 c         zj=c(3,nres+j)-zi
4134 C Uncomment following three lines for Ca-p interactions
4135           xj=c(1,j)-xi
4136           yj=c(2,j)-yi
4137           zj=c(3,j)-zi
4138           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4139           fac=rrij**expon2
4140           e1=fac*fac*aad(itypj,iteli)
4141           e2=fac*bad(itypj,iteli)
4142           if (iabs(j-i) .le. 2) then
4143             e1=scal14*e1
4144             e2=scal14*e2
4145             evdw2_14=evdw2_14+e1+e2
4146           endif
4147           evdwij=e1+e2
4148           evdw2=evdw2+evdwij
4149           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4150      &        'evdw2',i,j,evdwij
4151 C
4152 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4153 C
4154           fac=-(evdwij+e1)*rrij
4155           ggg(1)=xj*fac
4156           ggg(2)=yj*fac
4157           ggg(3)=zj*fac
4158 cgrad          if (j.lt.i) then
4159 cd          write (iout,*) 'j<i'
4160 C Uncomment following three lines for SC-p interactions
4161 c           do k=1,3
4162 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4163 c           enddo
4164 cgrad          else
4165 cd          write (iout,*) 'j>i'
4166 cgrad            do k=1,3
4167 cgrad              ggg(k)=-ggg(k)
4168 C Uncomment following line for SC-p interactions
4169 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4170 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4171 cgrad            enddo
4172 cgrad          endif
4173 cgrad          do k=1,3
4174 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4175 cgrad          enddo
4176 cgrad          kstart=min0(i+1,j)
4177 cgrad          kend=max0(i-1,j-1)
4178 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4179 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4180 cgrad          do k=kstart,kend
4181 cgrad            do l=1,3
4182 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4183 cgrad            enddo
4184 cgrad          enddo
4185           do k=1,3
4186             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4187             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4188           enddo
4189         enddo
4190
4191         enddo ! iint
4192       enddo ! i
4193       do i=1,nct
4194         do j=1,3
4195           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4196           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4197           gradx_scp(j,i)=expon*gradx_scp(j,i)
4198         enddo
4199       enddo
4200 C******************************************************************************
4201 C
4202 C                              N O T E !!!
4203 C
4204 C To save time the factor EXPON has been extracted from ALL components
4205 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4206 C use!
4207 C
4208 C******************************************************************************
4209       return
4210       end
4211 C--------------------------------------------------------------------------
4212       subroutine edis(ehpb)
4213 C
4214 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4215 C
4216       implicit real*8 (a-h,o-z)
4217       include 'DIMENSIONS'
4218       include 'COMMON.SBRIDGE'
4219       include 'COMMON.CHAIN'
4220       include 'COMMON.DERIV'
4221       include 'COMMON.VAR'
4222       include 'COMMON.INTERACT'
4223       include 'COMMON.IOUNITS'
4224       dimension ggg(3)
4225       ehpb=0.0D0
4226 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4227 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4228       if (link_end.eq.0) return
4229       do i=link_start,link_end
4230 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4231 C CA-CA distance used in regularization of structure.
4232         ii=ihpb(i)
4233         jj=jhpb(i)
4234 C iii and jjj point to the residues for which the distance is assigned.
4235         if (ii.gt.nres) then
4236           iii=ii-nres
4237           jjj=jj-nres
4238         else
4239           iii=ii
4240           jjj=jj
4241         endif
4242 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4243 c     &    dhpb(i),dhpb1(i),forcon(i)
4244 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4245 C    distance and angle dependent SS bond potential.
4246         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4247           call ssbond_ene(iii,jjj,eij)
4248           ehpb=ehpb+2*eij
4249 cd          write (iout,*) "eij",eij
4250         else if (ii.gt.nres .and. jj.gt.nres) then
4251 c Restraints from contact prediction
4252           dd=dist(ii,jj)
4253           if (dhpb1(i).gt.0.0d0) then
4254             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4255             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4256 c            write (iout,*) "beta nmr",
4257 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4258           else
4259             dd=dist(ii,jj)
4260             rdis=dd-dhpb(i)
4261 C Get the force constant corresponding to this distance.
4262             waga=forcon(i)
4263 C Calculate the contribution to energy.
4264             ehpb=ehpb+waga*rdis*rdis
4265 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4266 C
4267 C Evaluate gradient.
4268 C
4269             fac=waga*rdis/dd
4270           endif
4271           do j=1,3
4272             ggg(j)=fac*(c(j,jj)-c(j,ii))
4273           enddo
4274           do j=1,3
4275             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4276             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4277           enddo
4278           do k=1,3
4279             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4280             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4281           enddo
4282         else
4283 C Calculate the distance between the two points and its difference from the
4284 C target distance.
4285           dd=dist(ii,jj)
4286           if (dhpb1(i).gt.0.0d0) then
4287             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4288             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4289 c            write (iout,*) "alph nmr",
4290 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4291           else
4292             rdis=dd-dhpb(i)
4293 C Get the force constant corresponding to this distance.
4294             waga=forcon(i)
4295 C Calculate the contribution to energy.
4296             ehpb=ehpb+waga*rdis*rdis
4297 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4298 C
4299 C Evaluate gradient.
4300 C
4301             fac=waga*rdis/dd
4302           endif
4303 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4304 cd   &   ' waga=',waga,' fac=',fac
4305             do j=1,3
4306               ggg(j)=fac*(c(j,jj)-c(j,ii))
4307             enddo
4308 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4309 C If this is a SC-SC distance, we need to calculate the contributions to the
4310 C Cartesian gradient in the SC vectors (ghpbx).
4311           if (iii.lt.ii) then
4312           do j=1,3
4313             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4314             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4315           enddo
4316           endif
4317 cgrad        do j=iii,jjj-1
4318 cgrad          do k=1,3
4319 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4320 cgrad          enddo
4321 cgrad        enddo
4322           do k=1,3
4323             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4324             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4325           enddo
4326         endif
4327       enddo
4328       ehpb=0.5D0*ehpb
4329       return
4330       end
4331 C--------------------------------------------------------------------------
4332       subroutine ssbond_ene(i,j,eij)
4333 C
4334 C Calculate the distance and angle dependent SS-bond potential energy
4335 C using a free-energy function derived based on RHF/6-31G** ab initio
4336 C calculations of diethyl disulfide.
4337 C
4338 C A. Liwo and U. Kozlowska, 11/24/03
4339 C
4340       implicit real*8 (a-h,o-z)
4341       include 'DIMENSIONS'
4342       include 'COMMON.SBRIDGE'
4343       include 'COMMON.CHAIN'
4344       include 'COMMON.DERIV'
4345       include 'COMMON.LOCAL'
4346       include 'COMMON.INTERACT'
4347       include 'COMMON.VAR'
4348       include 'COMMON.IOUNITS'
4349       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4350       itypi=itype(i)
4351       xi=c(1,nres+i)
4352       yi=c(2,nres+i)
4353       zi=c(3,nres+i)
4354       dxi=dc_norm(1,nres+i)
4355       dyi=dc_norm(2,nres+i)
4356       dzi=dc_norm(3,nres+i)
4357 c      dsci_inv=dsc_inv(itypi)
4358       dsci_inv=vbld_inv(nres+i)
4359       itypj=itype(j)
4360 c      dscj_inv=dsc_inv(itypj)
4361       dscj_inv=vbld_inv(nres+j)
4362       xj=c(1,nres+j)-xi
4363       yj=c(2,nres+j)-yi
4364       zj=c(3,nres+j)-zi
4365       dxj=dc_norm(1,nres+j)
4366       dyj=dc_norm(2,nres+j)
4367       dzj=dc_norm(3,nres+j)
4368       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4369       rij=dsqrt(rrij)
4370       erij(1)=xj*rij
4371       erij(2)=yj*rij
4372       erij(3)=zj*rij
4373       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4374       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4375       om12=dxi*dxj+dyi*dyj+dzi*dzj
4376       do k=1,3
4377         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4378         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4379       enddo
4380       rij=1.0d0/rij
4381       deltad=rij-d0cm
4382       deltat1=1.0d0-om1
4383       deltat2=1.0d0+om2
4384       deltat12=om2-om1+2.0d0
4385       cosphi=om12-om1*om2
4386       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4387      &  +akct*deltad*deltat12
4388      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4389 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4390 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4391 c     &  " deltat12",deltat12," eij",eij
4392       ed=2*akcm*deltad+akct*deltat12
4393       pom1=akct*deltad
4394       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4395       eom1=-2*akth*deltat1-pom1-om2*pom2
4396       eom2= 2*akth*deltat2+pom1-om1*pom2
4397       eom12=pom2
4398       do k=1,3
4399         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4400         ghpbx(k,i)=ghpbx(k,i)-ggk
4401      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4402      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4403         ghpbx(k,j)=ghpbx(k,j)+ggk
4404      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4405      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4406         ghpbc(k,i)=ghpbc(k,i)-ggk
4407         ghpbc(k,j)=ghpbc(k,j)+ggk
4408       enddo
4409 C
4410 C Calculate the components of the gradient in DC and X
4411 C
4412 cgrad      do k=i,j-1
4413 cgrad        do l=1,3
4414 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4415 cgrad        enddo
4416 cgrad      enddo
4417       return
4418       end
4419 C--------------------------------------------------------------------------
4420       subroutine ebond(estr)
4421 c
4422 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4423 c
4424       implicit real*8 (a-h,o-z)
4425       include 'DIMENSIONS'
4426       include 'COMMON.LOCAL'
4427       include 'COMMON.GEO'
4428       include 'COMMON.INTERACT'
4429       include 'COMMON.DERIV'
4430       include 'COMMON.VAR'
4431       include 'COMMON.CHAIN'
4432       include 'COMMON.IOUNITS'
4433       include 'COMMON.NAMES'
4434       include 'COMMON.FFIELD'
4435       include 'COMMON.CONTROL'
4436       include 'COMMON.SETUP'
4437       double precision u(3),ud(3)
4438       estr=0.0d0
4439       do i=ibondp_start,ibondp_end
4440         diff = vbld(i)-vbldp0
4441 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4442         estr=estr+diff*diff
4443         do j=1,3
4444           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4445         enddo
4446 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4447       enddo
4448       estr=0.5d0*AKP*estr
4449 c
4450 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4451 c
4452       do i=ibond_start,ibond_end
4453         iti=itype(i)
4454         if (iti.ne.10) then
4455           nbi=nbondterm(iti)
4456           if (nbi.eq.1) then
4457             diff=vbld(i+nres)-vbldsc0(1,iti)
4458 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4459 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4460             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4461             do j=1,3
4462               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4463             enddo
4464           else
4465             do j=1,nbi
4466               diff=vbld(i+nres)-vbldsc0(j,iti)
4467               ud(j)=aksc(j,iti)*diff
4468               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4469             enddo
4470             uprod=u(1)
4471             do j=2,nbi
4472               uprod=uprod*u(j)
4473             enddo
4474             usum=0.0d0
4475             usumsqder=0.0d0
4476             do j=1,nbi
4477               uprod1=1.0d0
4478               uprod2=1.0d0
4479               do k=1,nbi
4480                 if (k.ne.j) then
4481                   uprod1=uprod1*u(k)
4482                   uprod2=uprod2*u(k)*u(k)
4483                 endif
4484               enddo
4485               usum=usum+uprod1
4486               usumsqder=usumsqder+ud(j)*uprod2
4487             enddo
4488             estr=estr+uprod/usum
4489             do j=1,3
4490              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4491             enddo
4492           endif
4493         endif
4494       enddo
4495       return
4496       end
4497 #ifdef CRYST_THETA
4498 C--------------------------------------------------------------------------
4499       subroutine ebend(etheta)
4500 C
4501 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4502 C angles gamma and its derivatives in consecutive thetas and gammas.
4503 C
4504       implicit real*8 (a-h,o-z)
4505       include 'DIMENSIONS'
4506       include 'COMMON.LOCAL'
4507       include 'COMMON.GEO'
4508       include 'COMMON.INTERACT'
4509       include 'COMMON.DERIV'
4510       include 'COMMON.VAR'
4511       include 'COMMON.CHAIN'
4512       include 'COMMON.IOUNITS'
4513       include 'COMMON.NAMES'
4514       include 'COMMON.FFIELD'
4515       include 'COMMON.CONTROL'
4516       common /calcthet/ term1,term2,termm,diffak,ratak,
4517      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4518      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4519       double precision y(2),z(2)
4520       delta=0.02d0*pi
4521 c      time11=dexp(-2*time)
4522 c      time12=1.0d0
4523       etheta=0.0D0
4524 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4525       do i=ithet_start,ithet_end
4526 C Zero the energy function and its derivative at 0 or pi.
4527         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4528         it=itype(i-1)
4529         if (i.gt.3) then
4530 #ifdef OSF
4531           phii=phi(i)
4532           if (phii.ne.phii) phii=150.0
4533 #else
4534           phii=phi(i)
4535 #endif
4536           y(1)=dcos(phii)
4537           y(2)=dsin(phii)
4538         else
4539           y(1)=0.0D0
4540           y(2)=0.0D0
4541         endif
4542         if (i.lt.nres) then
4543 #ifdef OSF
4544           phii1=phi(i+1)
4545           if (phii1.ne.phii1) phii1=150.0
4546           phii1=pinorm(phii1)
4547           z(1)=cos(phii1)
4548 #else
4549           phii1=phi(i+1)
4550           z(1)=dcos(phii1)
4551 #endif
4552           z(2)=dsin(phii1)
4553         else
4554           z(1)=0.0D0
4555           z(2)=0.0D0
4556         endif
4557 C Calculate the "mean" value of theta from the part of the distribution
4558 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4559 C In following comments this theta will be referred to as t_c.
4560         thet_pred_mean=0.0d0
4561         do k=1,2
4562           athetk=athet(k,it)
4563           bthetk=bthet(k,it)
4564           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4565         enddo
4566         dthett=thet_pred_mean*ssd
4567         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4568 C Derivatives of the "mean" values in gamma1 and gamma2.
4569         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4570         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4571         if (theta(i).gt.pi-delta) then
4572           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4573      &         E_tc0)
4574           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4575           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4576           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4577      &        E_theta)
4578           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4579      &        E_tc)
4580         else if (theta(i).lt.delta) then
4581           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4582           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4583           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4584      &        E_theta)
4585           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4586           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4587      &        E_tc)
4588         else
4589           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4590      &        E_theta,E_tc)
4591         endif
4592         etheta=etheta+ethetai
4593         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4594      &      'ebend',i,ethetai
4595         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4596         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4597         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4598       enddo
4599 C Ufff.... We've done all this!!!
4600       return
4601       end
4602 C---------------------------------------------------------------------------
4603       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4604      &     E_tc)
4605       implicit real*8 (a-h,o-z)
4606       include 'DIMENSIONS'
4607       include 'COMMON.LOCAL'
4608       include 'COMMON.IOUNITS'
4609       common /calcthet/ term1,term2,termm,diffak,ratak,
4610      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4611      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4612 C Calculate the contributions to both Gaussian lobes.
4613 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4614 C The "polynomial part" of the "standard deviation" of this part of
4615 C the distribution.
4616         sig=polthet(3,it)
4617         do j=2,0,-1
4618           sig=sig*thet_pred_mean+polthet(j,it)
4619         enddo
4620 C Derivative of the "interior part" of the "standard deviation of the"
4621 C gamma-dependent Gaussian lobe in t_c.
4622         sigtc=3*polthet(3,it)
4623         do j=2,1,-1
4624           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4625         enddo
4626         sigtc=sig*sigtc
4627 C Set the parameters of both Gaussian lobes of the distribution.
4628 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4629         fac=sig*sig+sigc0(it)
4630         sigcsq=fac+fac
4631         sigc=1.0D0/sigcsq
4632 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4633         sigsqtc=-4.0D0*sigcsq*sigtc
4634 c       print *,i,sig,sigtc,sigsqtc
4635 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4636         sigtc=-sigtc/(fac*fac)
4637 C Following variable is sigma(t_c)**(-2)
4638         sigcsq=sigcsq*sigcsq
4639         sig0i=sig0(it)
4640         sig0inv=1.0D0/sig0i**2
4641         delthec=thetai-thet_pred_mean
4642         delthe0=thetai-theta0i
4643         term1=-0.5D0*sigcsq*delthec*delthec
4644         term2=-0.5D0*sig0inv*delthe0*delthe0
4645 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4646 C NaNs in taking the logarithm. We extract the largest exponent which is added
4647 C to the energy (this being the log of the distribution) at the end of energy
4648 C term evaluation for this virtual-bond angle.
4649         if (term1.gt.term2) then
4650           termm=term1
4651           term2=dexp(term2-termm)
4652           term1=1.0d0
4653         else
4654           termm=term2
4655           term1=dexp(term1-termm)
4656           term2=1.0d0
4657         endif
4658 C The ratio between the gamma-independent and gamma-dependent lobes of
4659 C the distribution is a Gaussian function of thet_pred_mean too.
4660         diffak=gthet(2,it)-thet_pred_mean
4661         ratak=diffak/gthet(3,it)**2
4662         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4663 C Let's differentiate it in thet_pred_mean NOW.
4664         aktc=ak*ratak
4665 C Now put together the distribution terms to make complete distribution.
4666         termexp=term1+ak*term2
4667         termpre=sigc+ak*sig0i
4668 C Contribution of the bending energy from this theta is just the -log of
4669 C the sum of the contributions from the two lobes and the pre-exponential
4670 C factor. Simple enough, isn't it?
4671         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4672 C NOW the derivatives!!!
4673 C 6/6/97 Take into account the deformation.
4674         E_theta=(delthec*sigcsq*term1
4675      &       +ak*delthe0*sig0inv*term2)/termexp
4676         E_tc=((sigtc+aktc*sig0i)/termpre
4677      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4678      &       aktc*term2)/termexp)
4679       return
4680       end
4681 c-----------------------------------------------------------------------------
4682       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4683       implicit real*8 (a-h,o-z)
4684       include 'DIMENSIONS'
4685       include 'COMMON.LOCAL'
4686       include 'COMMON.IOUNITS'
4687       common /calcthet/ term1,term2,termm,diffak,ratak,
4688      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4689      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4690       delthec=thetai-thet_pred_mean
4691       delthe0=thetai-theta0i
4692 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4693       t3 = thetai-thet_pred_mean
4694       t6 = t3**2
4695       t9 = term1
4696       t12 = t3*sigcsq
4697       t14 = t12+t6*sigsqtc
4698       t16 = 1.0d0
4699       t21 = thetai-theta0i
4700       t23 = t21**2
4701       t26 = term2
4702       t27 = t21*t26
4703       t32 = termexp
4704       t40 = t32**2
4705       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4706      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4707      & *(-t12*t9-ak*sig0inv*t27)
4708       return
4709       end
4710 #else
4711 C--------------------------------------------------------------------------
4712       subroutine ebend(etheta)
4713 C
4714 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4715 C angles gamma and its derivatives in consecutive thetas and gammas.
4716 C ab initio-derived potentials from
4717 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4718 C
4719       implicit real*8 (a-h,o-z)
4720       include 'DIMENSIONS'
4721       include 'COMMON.LOCAL'
4722       include 'COMMON.GEO'
4723       include 'COMMON.INTERACT'
4724       include 'COMMON.DERIV'
4725       include 'COMMON.VAR'
4726       include 'COMMON.CHAIN'
4727       include 'COMMON.IOUNITS'
4728       include 'COMMON.NAMES'
4729       include 'COMMON.FFIELD'
4730       include 'COMMON.CONTROL'
4731       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4732      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4733      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4734      & sinph1ph2(maxdouble,maxdouble)
4735       logical lprn /.false./, lprn1 /.false./
4736       etheta=0.0D0
4737       do i=ithet_start,ithet_end
4738         dethetai=0.0d0
4739         dephii=0.0d0
4740         dephii1=0.0d0
4741         theti2=0.5d0*theta(i)
4742         ityp2=ithetyp(itype(i-1))
4743         do k=1,nntheterm
4744           coskt(k)=dcos(k*theti2)
4745           sinkt(k)=dsin(k*theti2)
4746         enddo
4747         if (i.gt.3) then
4748 #ifdef OSF
4749           phii=phi(i)
4750           if (phii.ne.phii) phii=150.0
4751 #else
4752           phii=phi(i)
4753 #endif
4754           ityp1=ithetyp(itype(i-2))
4755           do k=1,nsingle
4756             cosph1(k)=dcos(k*phii)
4757             sinph1(k)=dsin(k*phii)
4758           enddo
4759         else
4760           phii=0.0d0
4761           ityp1=nthetyp+1
4762           do k=1,nsingle
4763             cosph1(k)=0.0d0
4764             sinph1(k)=0.0d0
4765           enddo
4766         endif
4767         if (i.lt.nres) then
4768 #ifdef OSF
4769           phii1=phi(i+1)
4770           if (phii1.ne.phii1) phii1=150.0
4771           phii1=pinorm(phii1)
4772 #else
4773           phii1=phi(i+1)
4774 #endif
4775           ityp3=ithetyp(itype(i))
4776           do k=1,nsingle
4777             cosph2(k)=dcos(k*phii1)
4778             sinph2(k)=dsin(k*phii1)
4779           enddo
4780         else
4781           phii1=0.0d0
4782           ityp3=nthetyp+1
4783           do k=1,nsingle
4784             cosph2(k)=0.0d0
4785             sinph2(k)=0.0d0
4786           enddo
4787         endif
4788         ethetai=aa0thet(ityp1,ityp2,ityp3)
4789         do k=1,ndouble
4790           do l=1,k-1
4791             ccl=cosph1(l)*cosph2(k-l)
4792             ssl=sinph1(l)*sinph2(k-l)
4793             scl=sinph1(l)*cosph2(k-l)
4794             csl=cosph1(l)*sinph2(k-l)
4795             cosph1ph2(l,k)=ccl-ssl
4796             cosph1ph2(k,l)=ccl+ssl
4797             sinph1ph2(l,k)=scl+csl
4798             sinph1ph2(k,l)=scl-csl
4799           enddo
4800         enddo
4801         if (lprn) then
4802         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4803      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4804         write (iout,*) "coskt and sinkt"
4805         do k=1,nntheterm
4806           write (iout,*) k,coskt(k),sinkt(k)
4807         enddo
4808         endif
4809         do k=1,ntheterm
4810           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4811           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4812      &      *coskt(k)
4813           if (lprn)
4814      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4815      &     " ethetai",ethetai
4816         enddo
4817         if (lprn) then
4818         write (iout,*) "cosph and sinph"
4819         do k=1,nsingle
4820           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4821         enddo
4822         write (iout,*) "cosph1ph2 and sinph2ph2"
4823         do k=2,ndouble
4824           do l=1,k-1
4825             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4826      &         sinph1ph2(l,k),sinph1ph2(k,l)
4827           enddo
4828         enddo
4829         write(iout,*) "ethetai",ethetai
4830         endif
4831         do m=1,ntheterm2
4832           do k=1,nsingle
4833             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4834      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4835      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4836      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4837             ethetai=ethetai+sinkt(m)*aux
4838             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4839             dephii=dephii+k*sinkt(m)*(
4840      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4841      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4842             dephii1=dephii1+k*sinkt(m)*(
4843      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4844      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4845             if (lprn)
4846      &      write (iout,*) "m",m," k",k," bbthet",
4847      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4848      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4849      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4850      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4851           enddo
4852         enddo
4853         if (lprn)
4854      &  write(iout,*) "ethetai",ethetai
4855         do m=1,ntheterm3
4856           do k=2,ndouble
4857             do l=1,k-1
4858               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4859      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4860      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4861      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4862               ethetai=ethetai+sinkt(m)*aux
4863               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4864               dephii=dephii+l*sinkt(m)*(
4865      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4866      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4867      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4868      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4869               dephii1=dephii1+(k-l)*sinkt(m)*(
4870      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4871      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4872      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4873      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4874               if (lprn) then
4875               write (iout,*) "m",m," k",k," l",l," ffthet",
4876      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4877      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4878      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4879      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4880               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4881      &            cosph1ph2(k,l)*sinkt(m),
4882      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4883               endif
4884             enddo
4885           enddo
4886         enddo
4887 10      continue
4888         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4889      &   i,theta(i)*rad2deg,phii*rad2deg,
4890      &   phii1*rad2deg,ethetai
4891         etheta=etheta+ethetai
4892         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4893         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4894         gloc(nphi+i-2,icg)=wang*dethetai
4895       enddo
4896       return
4897       end
4898 #endif
4899 #ifdef CRYST_SC
4900 c-----------------------------------------------------------------------------
4901       subroutine esc(escloc)
4902 C Calculate the local energy of a side chain and its derivatives in the
4903 C corresponding virtual-bond valence angles THETA and the spherical angles
4904 C ALPHA and OMEGA.
4905       implicit real*8 (a-h,o-z)
4906       include 'DIMENSIONS'
4907       include 'COMMON.GEO'
4908       include 'COMMON.LOCAL'
4909       include 'COMMON.VAR'
4910       include 'COMMON.INTERACT'
4911       include 'COMMON.DERIV'
4912       include 'COMMON.CHAIN'
4913       include 'COMMON.IOUNITS'
4914       include 'COMMON.NAMES'
4915       include 'COMMON.FFIELD'
4916       include 'COMMON.CONTROL'
4917       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4918      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4919       common /sccalc/ time11,time12,time112,theti,it,nlobit
4920       delta=0.02d0*pi
4921       escloc=0.0D0
4922 c     write (iout,'(a)') 'ESC'
4923       do i=loc_start,loc_end
4924         it=itype(i)
4925         if (it.eq.10) goto 1
4926         nlobit=nlob(it)
4927 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4928 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4929         theti=theta(i+1)-pipol
4930         x(1)=dtan(theti)
4931         x(2)=alph(i)
4932         x(3)=omeg(i)
4933
4934         if (x(2).gt.pi-delta) then
4935           xtemp(1)=x(1)
4936           xtemp(2)=pi-delta
4937           xtemp(3)=x(3)
4938           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4939           xtemp(2)=pi
4940           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4941           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4942      &        escloci,dersc(2))
4943           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4944      &        ddersc0(1),dersc(1))
4945           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4946      &        ddersc0(3),dersc(3))
4947           xtemp(2)=pi-delta
4948           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4949           xtemp(2)=pi
4950           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4951           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4952      &            dersc0(2),esclocbi,dersc02)
4953           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4954      &            dersc12,dersc01)
4955           call splinthet(x(2),0.5d0*delta,ss,ssd)
4956           dersc0(1)=dersc01
4957           dersc0(2)=dersc02
4958           dersc0(3)=0.0d0
4959           do k=1,3
4960             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4961           enddo
4962           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4963 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4964 c    &             esclocbi,ss,ssd
4965           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4966 c         escloci=esclocbi
4967 c         write (iout,*) escloci
4968         else if (x(2).lt.delta) then
4969           xtemp(1)=x(1)
4970           xtemp(2)=delta
4971           xtemp(3)=x(3)
4972           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4973           xtemp(2)=0.0d0
4974           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4975           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4976      &        escloci,dersc(2))
4977           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4978      &        ddersc0(1),dersc(1))
4979           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4980      &        ddersc0(3),dersc(3))
4981           xtemp(2)=delta
4982           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4983           xtemp(2)=0.0d0
4984           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4985           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4986      &            dersc0(2),esclocbi,dersc02)
4987           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4988      &            dersc12,dersc01)
4989           dersc0(1)=dersc01
4990           dersc0(2)=dersc02
4991           dersc0(3)=0.0d0
4992           call splinthet(x(2),0.5d0*delta,ss,ssd)
4993           do k=1,3
4994             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4995           enddo
4996           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4997 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4998 c    &             esclocbi,ss,ssd
4999           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5000 c         write (iout,*) escloci
5001         else
5002           call enesc(x,escloci,dersc,ddummy,.false.)
5003         endif
5004
5005         escloc=escloc+escloci
5006         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5007      &     'escloc',i,escloci
5008 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5009
5010         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5011      &   wscloc*dersc(1)
5012         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5013         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5014     1   continue
5015       enddo
5016       return
5017       end
5018 C---------------------------------------------------------------------------
5019       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5020       implicit real*8 (a-h,o-z)
5021       include 'DIMENSIONS'
5022       include 'COMMON.GEO'
5023       include 'COMMON.LOCAL'
5024       include 'COMMON.IOUNITS'
5025       common /sccalc/ time11,time12,time112,theti,it,nlobit
5026       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5027       double precision contr(maxlob,-1:1)
5028       logical mixed
5029 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5030         escloc_i=0.0D0
5031         do j=1,3
5032           dersc(j)=0.0D0
5033           if (mixed) ddersc(j)=0.0d0
5034         enddo
5035         x3=x(3)
5036
5037 C Because of periodicity of the dependence of the SC energy in omega we have
5038 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5039 C To avoid underflows, first compute & store the exponents.
5040
5041         do iii=-1,1
5042
5043           x(3)=x3+iii*dwapi
5044
5045           do j=1,nlobit
5046             do k=1,3
5047               z(k)=x(k)-censc(k,j,it)
5048             enddo
5049             do k=1,3
5050               Axk=0.0D0
5051               do l=1,3
5052                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5053               enddo
5054               Ax(k,j,iii)=Axk
5055             enddo
5056             expfac=0.0D0
5057             do k=1,3
5058               expfac=expfac+Ax(k,j,iii)*z(k)
5059             enddo
5060             contr(j,iii)=expfac
5061           enddo ! j
5062
5063         enddo ! iii
5064
5065         x(3)=x3
5066 C As in the case of ebend, we want to avoid underflows in exponentiation and
5067 C subsequent NaNs and INFs in energy calculation.
5068 C Find the largest exponent
5069         emin=contr(1,-1)
5070         do iii=-1,1
5071           do j=1,nlobit
5072             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5073           enddo
5074         enddo
5075         emin=0.5D0*emin
5076 cd      print *,'it=',it,' emin=',emin
5077
5078 C Compute the contribution to SC energy and derivatives
5079         do iii=-1,1
5080
5081           do j=1,nlobit
5082 #ifdef OSF
5083             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5084             if(adexp.ne.adexp) adexp=1.0
5085             expfac=dexp(adexp)
5086 #else
5087             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5088 #endif
5089 cd          print *,'j=',j,' expfac=',expfac
5090             escloc_i=escloc_i+expfac
5091             do k=1,3
5092               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5093             enddo
5094             if (mixed) then
5095               do k=1,3,2
5096                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5097      &            +gaussc(k,2,j,it))*expfac
5098               enddo
5099             endif
5100           enddo
5101
5102         enddo ! iii
5103
5104         dersc(1)=dersc(1)/cos(theti)**2
5105         ddersc(1)=ddersc(1)/cos(theti)**2
5106         ddersc(3)=ddersc(3)
5107
5108         escloci=-(dlog(escloc_i)-emin)
5109         do j=1,3
5110           dersc(j)=dersc(j)/escloc_i
5111         enddo
5112         if (mixed) then
5113           do j=1,3,2
5114             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5115           enddo
5116         endif
5117       return
5118       end
5119 C------------------------------------------------------------------------------
5120       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5121       implicit real*8 (a-h,o-z)
5122       include 'DIMENSIONS'
5123       include 'COMMON.GEO'
5124       include 'COMMON.LOCAL'
5125       include 'COMMON.IOUNITS'
5126       common /sccalc/ time11,time12,time112,theti,it,nlobit
5127       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5128       double precision contr(maxlob)
5129       logical mixed
5130
5131       escloc_i=0.0D0
5132
5133       do j=1,3
5134         dersc(j)=0.0D0
5135       enddo
5136
5137       do j=1,nlobit
5138         do k=1,2
5139           z(k)=x(k)-censc(k,j,it)
5140         enddo
5141         z(3)=dwapi
5142         do k=1,3
5143           Axk=0.0D0
5144           do l=1,3
5145             Axk=Axk+gaussc(l,k,j,it)*z(l)
5146           enddo
5147           Ax(k,j)=Axk
5148         enddo
5149         expfac=0.0D0
5150         do k=1,3
5151           expfac=expfac+Ax(k,j)*z(k)
5152         enddo
5153         contr(j)=expfac
5154       enddo ! j
5155
5156 C As in the case of ebend, we want to avoid underflows in exponentiation and
5157 C subsequent NaNs and INFs in energy calculation.
5158 C Find the largest exponent
5159       emin=contr(1)
5160       do j=1,nlobit
5161         if (emin.gt.contr(j)) emin=contr(j)
5162       enddo
5163       emin=0.5D0*emin
5164
5165 C Compute the contribution to SC energy and derivatives
5166
5167       dersc12=0.0d0
5168       do j=1,nlobit
5169         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5170         escloc_i=escloc_i+expfac
5171         do k=1,2
5172           dersc(k)=dersc(k)+Ax(k,j)*expfac
5173         enddo
5174         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5175      &            +gaussc(1,2,j,it))*expfac
5176         dersc(3)=0.0d0
5177       enddo
5178
5179       dersc(1)=dersc(1)/cos(theti)**2
5180       dersc12=dersc12/cos(theti)**2
5181       escloci=-(dlog(escloc_i)-emin)
5182       do j=1,2
5183         dersc(j)=dersc(j)/escloc_i
5184       enddo
5185       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5186       return
5187       end
5188 #else
5189 c----------------------------------------------------------------------------------
5190       subroutine esc(escloc)
5191 C Calculate the local energy of a side chain and its derivatives in the
5192 C corresponding virtual-bond valence angles THETA and the spherical angles
5193 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5194 C added by Urszula Kozlowska. 07/11/2007
5195 C
5196       implicit real*8 (a-h,o-z)
5197       include 'DIMENSIONS'
5198       include 'COMMON.GEO'
5199       include 'COMMON.LOCAL'
5200       include 'COMMON.VAR'
5201       include 'COMMON.SCROT'
5202       include 'COMMON.INTERACT'
5203       include 'COMMON.DERIV'
5204       include 'COMMON.CHAIN'
5205       include 'COMMON.IOUNITS'
5206       include 'COMMON.NAMES'
5207       include 'COMMON.FFIELD'
5208       include 'COMMON.CONTROL'
5209       include 'COMMON.VECTORS'
5210       double precision x_prime(3),y_prime(3),z_prime(3)
5211      &    , sumene,dsc_i,dp2_i,x(65),
5212      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5213      &    de_dxx,de_dyy,de_dzz,de_dt
5214       double precision s1_t,s1_6_t,s2_t,s2_6_t
5215       double precision
5216      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5217      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5218      & dt_dCi(3),dt_dCi1(3)
5219       common /sccalc/ time11,time12,time112,theti,it,nlobit
5220       delta=0.02d0*pi
5221       escloc=0.0D0
5222       do i=loc_start,loc_end
5223         costtab(i+1) =dcos(theta(i+1))
5224         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5225         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5226         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5227         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5228         cosfac=dsqrt(cosfac2)
5229         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5230         sinfac=dsqrt(sinfac2)
5231         it=itype(i)
5232         if (it.eq.10) goto 1
5233 c
5234 C  Compute the axes of tghe local cartesian coordinates system; store in
5235 c   x_prime, y_prime and z_prime
5236 c
5237         do j=1,3
5238           x_prime(j) = 0.00
5239           y_prime(j) = 0.00
5240           z_prime(j) = 0.00
5241         enddo
5242 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5243 C     &   dc_norm(3,i+nres)
5244         do j = 1,3
5245           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5246           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5247         enddo
5248         do j = 1,3
5249           z_prime(j) = -uz(j,i-1)
5250         enddo
5251 c       write (2,*) "i",i
5252 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5253 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5254 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5255 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5256 c      & " xy",scalar(x_prime(1),y_prime(1)),
5257 c      & " xz",scalar(x_prime(1),z_prime(1)),
5258 c      & " yy",scalar(y_prime(1),y_prime(1)),
5259 c      & " yz",scalar(y_prime(1),z_prime(1)),
5260 c      & " zz",scalar(z_prime(1),z_prime(1))
5261 c
5262 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5263 C to local coordinate system. Store in xx, yy, zz.
5264 c
5265         xx=0.0d0
5266         yy=0.0d0
5267         zz=0.0d0
5268         do j = 1,3
5269           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5270           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5271           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5272         enddo
5273
5274         xxtab(i)=xx
5275         yytab(i)=yy
5276         zztab(i)=zz
5277 C
5278 C Compute the energy of the ith side cbain
5279 C
5280 c        write (2,*) "xx",xx," yy",yy," zz",zz
5281         it=itype(i)
5282         do j = 1,65
5283           x(j) = sc_parmin(j,it)
5284         enddo
5285 #ifdef CHECK_COORD
5286 Cc diagnostics - remove later
5287         xx1 = dcos(alph(2))
5288         yy1 = dsin(alph(2))*dcos(omeg(2))
5289         zz1 = -dsin(alph(2))*dsin(omeg(2))
5290         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5291      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5292      &    xx1,yy1,zz1
5293 C,"  --- ", xx_w,yy_w,zz_w
5294 c end diagnostics
5295 #endif
5296         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5297      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5298      &   + x(10)*yy*zz
5299         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5300      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5301      & + x(20)*yy*zz
5302         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5303      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5304      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5305      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5306      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5307      &  +x(40)*xx*yy*zz
5308         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5309      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5310      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5311      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5312      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5313      &  +x(60)*xx*yy*zz
5314         dsc_i   = 0.743d0+x(61)
5315         dp2_i   = 1.9d0+x(62)
5316         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5317      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5318         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5319      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5320         s1=(1+x(63))/(0.1d0 + dscp1)
5321         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5322         s2=(1+x(65))/(0.1d0 + dscp2)
5323         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5324         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5325      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5326 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5327 c     &   sumene4,
5328 c     &   dscp1,dscp2,sumene
5329 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5330         escloc = escloc + sumene
5331 c        write (2,*) "i",i," escloc",sumene,escloc
5332 #ifdef DEBUG
5333 C
5334 C This section to check the numerical derivatives of the energy of ith side
5335 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5336 C #define DEBUG in the code to turn it on.
5337 C
5338         write (2,*) "sumene               =",sumene
5339         aincr=1.0d-7
5340         xxsave=xx
5341         xx=xx+aincr
5342         write (2,*) xx,yy,zz
5343         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5344         de_dxx_num=(sumenep-sumene)/aincr
5345         xx=xxsave
5346         write (2,*) "xx+ sumene from enesc=",sumenep
5347         yysave=yy
5348         yy=yy+aincr
5349         write (2,*) xx,yy,zz
5350         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5351         de_dyy_num=(sumenep-sumene)/aincr
5352         yy=yysave
5353         write (2,*) "yy+ sumene from enesc=",sumenep
5354         zzsave=zz
5355         zz=zz+aincr
5356         write (2,*) xx,yy,zz
5357         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5358         de_dzz_num=(sumenep-sumene)/aincr
5359         zz=zzsave
5360         write (2,*) "zz+ sumene from enesc=",sumenep
5361         costsave=cost2tab(i+1)
5362         sintsave=sint2tab(i+1)
5363         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5364         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5365         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5366         de_dt_num=(sumenep-sumene)/aincr
5367         write (2,*) " t+ sumene from enesc=",sumenep
5368         cost2tab(i+1)=costsave
5369         sint2tab(i+1)=sintsave
5370 C End of diagnostics section.
5371 #endif
5372 C
5373 C Compute the gradient of esc
5374 C
5375         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5376         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5377         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5378         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5379         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5380         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5381         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5382         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5383         pom1=(sumene3*sint2tab(i+1)+sumene1)
5384      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5385         pom2=(sumene4*cost2tab(i+1)+sumene2)
5386      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5387         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5388         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5389      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5390      &  +x(40)*yy*zz
5391         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5392         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5393      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5394      &  +x(60)*yy*zz
5395         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5396      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5397      &        +(pom1+pom2)*pom_dx
5398 #ifdef DEBUG
5399         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5400 #endif
5401 C
5402         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5403         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5404      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5405      &  +x(40)*xx*zz
5406         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5407         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5408      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5409      &  +x(59)*zz**2 +x(60)*xx*zz
5410         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5411      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5412      &        +(pom1-pom2)*pom_dy
5413 #ifdef DEBUG
5414         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5415 #endif
5416 C
5417         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5418      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5419      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5420      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5421      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5422      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5423      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5424      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5425 #ifdef DEBUG
5426         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5427 #endif
5428 C
5429         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5430      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5431      &  +pom1*pom_dt1+pom2*pom_dt2
5432 #ifdef DEBUG
5433         write(2,*), "de_dt = ", de_dt,de_dt_num
5434 #endif
5435 c
5436 C
5437        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5438        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5439        cosfac2xx=cosfac2*xx
5440        sinfac2yy=sinfac2*yy
5441        do k = 1,3
5442          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5443      &      vbld_inv(i+1)
5444          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5445      &      vbld_inv(i)
5446          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5447          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5448 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5449 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5450 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5451 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5452          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5453          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5454          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5455          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5456          dZZ_Ci1(k)=0.0d0
5457          dZZ_Ci(k)=0.0d0
5458          do j=1,3
5459            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5460            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5461          enddo
5462
5463          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5464          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5465          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5466 c
5467          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5468          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5469        enddo
5470
5471        do k=1,3
5472          dXX_Ctab(k,i)=dXX_Ci(k)
5473          dXX_C1tab(k,i)=dXX_Ci1(k)
5474          dYY_Ctab(k,i)=dYY_Ci(k)
5475          dYY_C1tab(k,i)=dYY_Ci1(k)
5476          dZZ_Ctab(k,i)=dZZ_Ci(k)
5477          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5478          dXX_XYZtab(k,i)=dXX_XYZ(k)
5479          dYY_XYZtab(k,i)=dYY_XYZ(k)
5480          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5481        enddo
5482
5483        do k = 1,3
5484 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5485 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5486 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5487 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5488 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5489 c     &    dt_dci(k)
5490 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5491 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5492          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5493      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5494          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5495      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5496          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5497      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5498        enddo
5499 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5500 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5501
5502 C to check gradient call subroutine check_grad
5503
5504     1 continue
5505       enddo
5506       return
5507       end
5508 c------------------------------------------------------------------------------
5509       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5510       implicit none
5511       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5512      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5513       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5514      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5515      &   + x(10)*yy*zz
5516       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5517      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5518      & + x(20)*yy*zz
5519       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5520      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5521      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5522      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5523      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5524      &  +x(40)*xx*yy*zz
5525       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5526      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5527      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5528      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5529      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5530      &  +x(60)*xx*yy*zz
5531       dsc_i   = 0.743d0+x(61)
5532       dp2_i   = 1.9d0+x(62)
5533       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5534      &          *(xx*cost2+yy*sint2))
5535       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5536      &          *(xx*cost2-yy*sint2))
5537       s1=(1+x(63))/(0.1d0 + dscp1)
5538       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5539       s2=(1+x(65))/(0.1d0 + dscp2)
5540       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5541       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5542      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5543       enesc=sumene
5544       return
5545       end
5546 #endif
5547 c------------------------------------------------------------------------------
5548       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5549 C
5550 C This procedure calculates two-body contact function g(rij) and its derivative:
5551 C
5552 C           eps0ij                                     !       x < -1
5553 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5554 C            0                                         !       x > 1
5555 C
5556 C where x=(rij-r0ij)/delta
5557 C
5558 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5559 C
5560       implicit none
5561       double precision rij,r0ij,eps0ij,fcont,fprimcont
5562       double precision x,x2,x4,delta
5563 c     delta=0.02D0*r0ij
5564 c      delta=0.2D0*r0ij
5565       x=(rij-r0ij)/delta
5566       if (x.lt.-1.0D0) then
5567         fcont=eps0ij
5568         fprimcont=0.0D0
5569       else if (x.le.1.0D0) then
5570         x2=x*x
5571         x4=x2*x2
5572         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5573         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5574       else
5575         fcont=0.0D0
5576         fprimcont=0.0D0
5577       endif
5578       return
5579       end
5580 c------------------------------------------------------------------------------
5581       subroutine splinthet(theti,delta,ss,ssder)
5582       implicit real*8 (a-h,o-z)
5583       include 'DIMENSIONS'
5584       include 'COMMON.VAR'
5585       include 'COMMON.GEO'
5586       thetup=pi-delta
5587       thetlow=delta
5588       if (theti.gt.pipol) then
5589         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5590       else
5591         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5592         ssder=-ssder
5593       endif
5594       return
5595       end
5596 c------------------------------------------------------------------------------
5597       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5598       implicit none
5599       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5600       double precision ksi,ksi2,ksi3,a1,a2,a3
5601       a1=fprim0*delta/(f1-f0)
5602       a2=3.0d0-2.0d0*a1
5603       a3=a1-2.0d0
5604       ksi=(x-x0)/delta
5605       ksi2=ksi*ksi
5606       ksi3=ksi2*ksi
5607       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5608       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5609       return
5610       end
5611 c------------------------------------------------------------------------------
5612       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5613       implicit none
5614       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5615       double precision ksi,ksi2,ksi3,a1,a2,a3
5616       ksi=(x-x0)/delta
5617       ksi2=ksi*ksi
5618       ksi3=ksi2*ksi
5619       a1=fprim0x*delta
5620       a2=3*(f1x-f0x)-2*fprim0x*delta
5621       a3=fprim0x*delta-2*(f1x-f0x)
5622       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5623       return
5624       end
5625 C-----------------------------------------------------------------------------
5626 #ifdef CRYST_TOR
5627 C-----------------------------------------------------------------------------
5628       subroutine etor(etors,edihcnstr)
5629       implicit real*8 (a-h,o-z)
5630       include 'DIMENSIONS'
5631       include 'COMMON.VAR'
5632       include 'COMMON.GEO'
5633       include 'COMMON.LOCAL'
5634       include 'COMMON.TORSION'
5635       include 'COMMON.INTERACT'
5636       include 'COMMON.DERIV'
5637       include 'COMMON.CHAIN'
5638       include 'COMMON.NAMES'
5639       include 'COMMON.IOUNITS'
5640       include 'COMMON.FFIELD'
5641       include 'COMMON.TORCNSTR'
5642       include 'COMMON.CONTROL'
5643       logical lprn
5644 C Set lprn=.true. for debugging
5645       lprn=.false.
5646 c      lprn=.true.
5647       etors=0.0D0
5648       do i=iphi_start,iphi_end
5649       etors_ii=0.0D0
5650         itori=itortyp(itype(i-2))
5651         itori1=itortyp(itype(i-1))
5652         phii=phi(i)
5653         gloci=0.0D0
5654 C Proline-Proline pair is a special case...
5655         if (itori.eq.3 .and. itori1.eq.3) then
5656           if (phii.gt.-dwapi3) then
5657             cosphi=dcos(3*phii)
5658             fac=1.0D0/(1.0D0-cosphi)
5659             etorsi=v1(1,3,3)*fac
5660             etorsi=etorsi+etorsi
5661             etors=etors+etorsi-v1(1,3,3)
5662             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5663             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5664           endif
5665           do j=1,3
5666             v1ij=v1(j+1,itori,itori1)
5667             v2ij=v2(j+1,itori,itori1)
5668             cosphi=dcos(j*phii)
5669             sinphi=dsin(j*phii)
5670             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5671             if (energy_dec) etors_ii=etors_ii+
5672      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5673             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5674           enddo
5675         else
5676           do j=1,nterm_old
5677             v1ij=v1(j,itori,itori1)
5678             v2ij=v2(j,itori,itori1)
5679             cosphi=dcos(j*phii)
5680             sinphi=dsin(j*phii)
5681             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5682             if (energy_dec) etors_ii=etors_ii+
5683      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5684             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5685           enddo
5686         endif
5687         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5688      &        'etor',i,etors_ii
5689         if (lprn)
5690      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5691      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5692      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5693         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5694 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5695       enddo
5696 ! 6/20/98 - dihedral angle constraints
5697       edihcnstr=0.0d0
5698       do i=1,ndih_constr
5699         itori=idih_constr(i)
5700         phii=phi(itori)
5701         difi=phii-phi0(i)
5702         if (difi.gt.drange(i)) then
5703           difi=difi-drange(i)
5704           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5705           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5706         else if (difi.lt.-drange(i)) then
5707           difi=difi+drange(i)
5708           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5709           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5710         endif
5711 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5712 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5713       enddo
5714 !      write (iout,*) 'edihcnstr',edihcnstr
5715       return
5716       end
5717 c------------------------------------------------------------------------------
5718       subroutine etor_d(etors_d)
5719       etors_d=0.0d0
5720       return
5721       end
5722 c----------------------------------------------------------------------------
5723 #else
5724       subroutine etor(etors,edihcnstr)
5725       implicit real*8 (a-h,o-z)
5726       include 'DIMENSIONS'
5727       include 'COMMON.VAR'
5728       include 'COMMON.GEO'
5729       include 'COMMON.LOCAL'
5730       include 'COMMON.TORSION'
5731       include 'COMMON.INTERACT'
5732       include 'COMMON.DERIV'
5733       include 'COMMON.CHAIN'
5734       include 'COMMON.NAMES'
5735       include 'COMMON.IOUNITS'
5736       include 'COMMON.FFIELD'
5737       include 'COMMON.TORCNSTR'
5738       include 'COMMON.CONTROL'
5739       logical lprn
5740 C Set lprn=.true. for debugging
5741       lprn=.false.
5742 c     lprn=.true.
5743       etors=0.0D0
5744       do i=iphi_start,iphi_end
5745       etors_ii=0.0D0
5746         itori=itortyp(itype(i-2))
5747         itori1=itortyp(itype(i-1))
5748         phii=phi(i)
5749         gloci=0.0D0
5750 C Regular cosine and sine terms
5751         do j=1,nterm(itori,itori1)
5752           v1ij=v1(j,itori,itori1)
5753           v2ij=v2(j,itori,itori1)
5754           cosphi=dcos(j*phii)
5755           sinphi=dsin(j*phii)
5756           etors=etors+v1ij*cosphi+v2ij*sinphi
5757           if (energy_dec) etors_ii=etors_ii+
5758      &                v1ij*cosphi+v2ij*sinphi
5759           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5760         enddo
5761 C Lorentz terms
5762 C                         v1
5763 C  E = SUM ----------------------------------- - v1
5764 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5765 C
5766         cosphi=dcos(0.5d0*phii)
5767         sinphi=dsin(0.5d0*phii)
5768         do j=1,nlor(itori,itori1)
5769           vl1ij=vlor1(j,itori,itori1)
5770           vl2ij=vlor2(j,itori,itori1)
5771           vl3ij=vlor3(j,itori,itori1)
5772           pom=vl2ij*cosphi+vl3ij*sinphi
5773           pom1=1.0d0/(pom*pom+1.0d0)
5774           etors=etors+vl1ij*pom1
5775           if (energy_dec) etors_ii=etors_ii+
5776      &                vl1ij*pom1
5777           pom=-pom*pom1*pom1
5778           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5779         enddo
5780 C Subtract the constant term
5781         etors=etors-v0(itori,itori1)
5782           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5783      &         'etor',i,etors_ii-v0(itori,itori1)
5784         if (lprn)
5785      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5786      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5787      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5788         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5789 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5790       enddo
5791 ! 6/20/98 - dihedral angle constraints
5792       edihcnstr=0.0d0
5793 c      do i=1,ndih_constr
5794       do i=idihconstr_start,idihconstr_end
5795         itori=idih_constr(i)
5796         phii=phi(itori)
5797         difi=pinorm(phii-phi0(i))
5798         if (difi.gt.drange(i)) then
5799           difi=difi-drange(i)
5800           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5801           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5802         else if (difi.lt.-drange(i)) then
5803           difi=difi+drange(i)
5804           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5805           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5806         else
5807           difi=0.0
5808         endif
5809 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5810 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5811 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5812       enddo
5813 cd       write (iout,*) 'edihcnstr',edihcnstr
5814       return
5815       end
5816 c----------------------------------------------------------------------------
5817       subroutine etor_d(etors_d)
5818 C 6/23/01 Compute double torsional energy
5819       implicit real*8 (a-h,o-z)
5820       include 'DIMENSIONS'
5821       include 'COMMON.VAR'
5822       include 'COMMON.GEO'
5823       include 'COMMON.LOCAL'
5824       include 'COMMON.TORSION'
5825       include 'COMMON.INTERACT'
5826       include 'COMMON.DERIV'
5827       include 'COMMON.CHAIN'
5828       include 'COMMON.NAMES'
5829       include 'COMMON.IOUNITS'
5830       include 'COMMON.FFIELD'
5831       include 'COMMON.TORCNSTR'
5832       logical lprn
5833 C Set lprn=.true. for debugging
5834       lprn=.false.
5835 c     lprn=.true.
5836       etors_d=0.0D0
5837       do i=iphid_start,iphid_end
5838         itori=itortyp(itype(i-2))
5839         itori1=itortyp(itype(i-1))
5840         itori2=itortyp(itype(i))
5841         phii=phi(i)
5842         phii1=phi(i+1)
5843         gloci1=0.0D0
5844         gloci2=0.0D0
5845 C Regular cosine and sine terms
5846         do j=1,ntermd_1(itori,itori1,itori2)
5847           v1cij=v1c(1,j,itori,itori1,itori2)
5848           v1sij=v1s(1,j,itori,itori1,itori2)
5849           v2cij=v1c(2,j,itori,itori1,itori2)
5850           v2sij=v1s(2,j,itori,itori1,itori2)
5851           cosphi1=dcos(j*phii)
5852           sinphi1=dsin(j*phii)
5853           cosphi2=dcos(j*phii1)
5854           sinphi2=dsin(j*phii1)
5855           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5856      &     v2cij*cosphi2+v2sij*sinphi2
5857           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5858           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5859         enddo
5860         do k=2,ntermd_2(itori,itori1,itori2)
5861           do l=1,k-1
5862             v1cdij = v2c(k,l,itori,itori1,itori2)
5863             v2cdij = v2c(l,k,itori,itori1,itori2)
5864             v1sdij = v2s(k,l,itori,itori1,itori2)
5865             v2sdij = v2s(l,k,itori,itori1,itori2)
5866             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5867             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5868             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5869             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5870             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5871      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5872             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5873      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5874             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5875      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5876           enddo
5877         enddo
5878         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5879         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5880       enddo
5881       return
5882       end
5883 #endif
5884 c------------------------------------------------------------------------------
5885       subroutine eback_sc_corr(esccor)
5886 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5887 c        conformational states; temporarily implemented as differences
5888 c        between UNRES torsional potentials (dependent on three types of
5889 c        residues) and the torsional potentials dependent on all 20 types
5890 c        of residues computed from AM1  energy surfaces of terminally-blocked
5891 c        amino-acid residues.
5892       implicit real*8 (a-h,o-z)
5893       include 'DIMENSIONS'
5894       include 'COMMON.VAR'
5895       include 'COMMON.GEO'
5896       include 'COMMON.LOCAL'
5897       include 'COMMON.TORSION'
5898       include 'COMMON.SCCOR'
5899       include 'COMMON.INTERACT'
5900       include 'COMMON.DERIV'
5901       include 'COMMON.CHAIN'
5902       include 'COMMON.NAMES'
5903       include 'COMMON.IOUNITS'
5904       include 'COMMON.FFIELD'
5905       include 'COMMON.CONTROL'
5906       logical lprn
5907 C Set lprn=.true. for debugging
5908       lprn=.false.
5909 c      lprn=.true.
5910 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5911       esccor=0.0D0
5912       do i=iphi_start,iphi_end
5913         esccor_ii=0.0D0
5914         itori=itype(i-2)
5915         itori1=itype(i-1)
5916         phii=phi(i)
5917         gloci=0.0D0
5918         do j=1,nterm_sccor
5919           v1ij=v1sccor(j,itori,itori1)
5920           v2ij=v2sccor(j,itori,itori1)
5921           cosphi=dcos(j*phii)
5922           sinphi=dsin(j*phii)
5923           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5924           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5925         enddo
5926         if (lprn)
5927      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5928      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5929      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5930         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5931       enddo
5932       return
5933       end
5934 c----------------------------------------------------------------------------
5935       subroutine multibody(ecorr)
5936 C This subroutine calculates multi-body contributions to energy following
5937 C the idea of Skolnick et al. If side chains I and J make a contact and
5938 C at the same time side chains I+1 and J+1 make a contact, an extra
5939 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5940       implicit real*8 (a-h,o-z)
5941       include 'DIMENSIONS'
5942       include 'COMMON.IOUNITS'
5943       include 'COMMON.DERIV'
5944       include 'COMMON.INTERACT'
5945       include 'COMMON.CONTACTS'
5946       double precision gx(3),gx1(3)
5947       logical lprn
5948
5949 C Set lprn=.true. for debugging
5950       lprn=.false.
5951
5952       if (lprn) then
5953         write (iout,'(a)') 'Contact function values:'
5954         do i=nnt,nct-2
5955           write (iout,'(i2,20(1x,i2,f10.5))')
5956      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5957         enddo
5958       endif
5959       ecorr=0.0D0
5960       do i=nnt,nct
5961         do j=1,3
5962           gradcorr(j,i)=0.0D0
5963           gradxorr(j,i)=0.0D0
5964         enddo
5965       enddo
5966       do i=nnt,nct-2
5967
5968         DO ISHIFT = 3,4
5969
5970         i1=i+ishift
5971         num_conti=num_cont(i)
5972         num_conti1=num_cont(i1)
5973         do jj=1,num_conti
5974           j=jcont(jj,i)
5975           do kk=1,num_conti1
5976             j1=jcont(kk,i1)
5977             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5978 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5979 cd   &                   ' ishift=',ishift
5980 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5981 C The system gains extra energy.
5982               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5983             endif   ! j1==j+-ishift
5984           enddo     ! kk
5985         enddo       ! jj
5986
5987         ENDDO ! ISHIFT
5988
5989       enddo         ! i
5990       return
5991       end
5992 c------------------------------------------------------------------------------
5993       double precision function esccorr(i,j,k,l,jj,kk)
5994       implicit real*8 (a-h,o-z)
5995       include 'DIMENSIONS'
5996       include 'COMMON.IOUNITS'
5997       include 'COMMON.DERIV'
5998       include 'COMMON.INTERACT'
5999       include 'COMMON.CONTACTS'
6000       double precision gx(3),gx1(3)
6001       logical lprn
6002       lprn=.false.
6003       eij=facont(jj,i)
6004       ekl=facont(kk,k)
6005 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6006 C Calculate the multi-body contribution to energy.
6007 C Calculate multi-body contributions to the gradient.
6008 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6009 cd   & k,l,(gacont(m,kk,k),m=1,3)
6010       do m=1,3
6011         gx(m) =ekl*gacont(m,jj,i)
6012         gx1(m)=eij*gacont(m,kk,k)
6013         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6014         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6015         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6016         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6017       enddo
6018       do m=i,j-1
6019         do ll=1,3
6020           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6021         enddo
6022       enddo
6023       do m=k,l-1
6024         do ll=1,3
6025           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6026         enddo
6027       enddo
6028       esccorr=-eij*ekl
6029       return
6030       end
6031 c------------------------------------------------------------------------------
6032       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6033 C This subroutine calculates multi-body contributions to hydrogen-bonding
6034       implicit real*8 (a-h,o-z)
6035       include 'DIMENSIONS'
6036       include 'COMMON.IOUNITS'
6037 #ifdef MPI
6038       include "mpif.h"
6039       parameter (max_cont=maxconts)
6040       parameter (max_dim=26)
6041       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6042       double precision zapas(max_dim,maxconts,max_fg_procs),
6043      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6044       common /przechowalnia/ zapas
6045       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6046      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6047 #endif
6048       include 'COMMON.SETUP'
6049       include 'COMMON.FFIELD'
6050       include 'COMMON.DERIV'
6051       include 'COMMON.INTERACT'
6052       include 'COMMON.CONTACTS'
6053       include 'COMMON.CONTROL'
6054       include 'COMMON.LOCAL'
6055       double precision gx(3),gx1(3),time00
6056       logical lprn,ldone
6057
6058 C Set lprn=.true. for debugging
6059       lprn=.false.
6060 #ifdef MPI
6061       n_corr=0
6062       n_corr1=0
6063       if (nfgtasks.le.1) goto 30
6064       if (lprn) then
6065         write (iout,'(a)') 'Contact function values before RECEIVE:'
6066         do i=nnt,nct-2
6067           write (iout,'(2i3,50(1x,i2,f5.2))')
6068      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6069      &    j=1,num_cont_hb(i))
6070         enddo
6071       endif
6072       call flush(iout)
6073       do i=1,ntask_cont_from
6074         ncont_recv(i)=0
6075       enddo
6076       do i=1,ntask_cont_to
6077         ncont_sent(i)=0
6078       enddo
6079 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6080 c     & ntask_cont_to
6081 C Make the list of contacts to send to send to other procesors
6082 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6083 c      call flush(iout)
6084       do i=iturn3_start,iturn3_end
6085 c        write (iout,*) "make contact list turn3",i," num_cont",
6086 c     &    num_cont_hb(i)
6087         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6088       enddo
6089       do i=iturn4_start,iturn4_end
6090 c        write (iout,*) "make contact list turn4",i," num_cont",
6091 c     &   num_cont_hb(i)
6092         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6093       enddo
6094       do ii=1,nat_sent
6095         i=iat_sent(ii)
6096 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6097 c     &    num_cont_hb(i)
6098         do j=1,num_cont_hb(i)
6099         do k=1,4
6100           jjc=jcont_hb(j,i)
6101           iproc=iint_sent_local(k,jjc,ii)
6102 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6103           if (iproc.gt.0) then
6104             ncont_sent(iproc)=ncont_sent(iproc)+1
6105             nn=ncont_sent(iproc)
6106             zapas(1,nn,iproc)=i
6107             zapas(2,nn,iproc)=jjc
6108             zapas(3,nn,iproc)=facont_hb(j,i)
6109             zapas(4,nn,iproc)=ees0p(j,i)
6110             zapas(5,nn,iproc)=ees0m(j,i)
6111             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6112             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6113             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6114             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6115             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6116             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6117             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6118             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6119             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6120             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6121             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6122             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6123             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6124             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6125             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6126             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6127             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6128             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6129             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6130             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6131             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6132           endif
6133         enddo
6134         enddo
6135       enddo
6136       if (lprn) then
6137       write (iout,*)
6138      &  "Numbers of contacts to be sent to other processors",
6139      &  (ncont_sent(i),i=1,ntask_cont_to)
6140       write (iout,*) "Contacts sent"
6141       do ii=1,ntask_cont_to
6142         nn=ncont_sent(ii)
6143         iproc=itask_cont_to(ii)
6144         write (iout,*) nn," contacts to processor",iproc,
6145      &   " of CONT_TO_COMM group"
6146         do i=1,nn
6147           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6148         enddo
6149       enddo
6150       call flush(iout)
6151       endif
6152       CorrelType=477
6153       CorrelID=fg_rank+1
6154       CorrelType1=478
6155       CorrelID1=nfgtasks+fg_rank+1
6156       ireq=0
6157 C Receive the numbers of needed contacts from other processors
6158       do ii=1,ntask_cont_from
6159         iproc=itask_cont_from(ii)
6160         ireq=ireq+1
6161         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6162      &    FG_COMM,req(ireq),IERR)
6163       enddo
6164 c      write (iout,*) "IRECV ended"
6165 c      call flush(iout)
6166 C Send the number of contacts needed by other processors
6167       do ii=1,ntask_cont_to
6168         iproc=itask_cont_to(ii)
6169         ireq=ireq+1
6170         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6171      &    FG_COMM,req(ireq),IERR)
6172       enddo
6173 c      write (iout,*) "ISEND ended"
6174 c      write (iout,*) "number of requests (nn)",ireq
6175       call flush(iout)
6176       if (ireq.gt.0)
6177      &  call MPI_Waitall(ireq,req,status_array,ierr)
6178 c      write (iout,*)
6179 c     &  "Numbers of contacts to be received from other processors",
6180 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6181 c      call flush(iout)
6182 C Receive contacts
6183       ireq=0
6184       do ii=1,ntask_cont_from
6185         iproc=itask_cont_from(ii)
6186         nn=ncont_recv(ii)
6187 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6188 c     &   " of CONT_TO_COMM group"
6189         call flush(iout)
6190         if (nn.gt.0) then
6191           ireq=ireq+1
6192           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6193      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6194 c          write (iout,*) "ireq,req",ireq,req(ireq)
6195         endif
6196       enddo
6197 C Send the contacts to processors that need them
6198       do ii=1,ntask_cont_to
6199         iproc=itask_cont_to(ii)
6200         nn=ncont_sent(ii)
6201 c        write (iout,*) nn," contacts to processor",iproc,
6202 c     &   " of CONT_TO_COMM group"
6203         if (nn.gt.0) then
6204           ireq=ireq+1
6205           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6206      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6207 c          write (iout,*) "ireq,req",ireq,req(ireq)
6208 c          do i=1,nn
6209 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6210 c          enddo
6211         endif
6212       enddo
6213 c      write (iout,*) "number of requests (contacts)",ireq
6214 c      write (iout,*) "req",(req(i),i=1,4)
6215 c      call flush(iout)
6216       if (ireq.gt.0)
6217      & call MPI_Waitall(ireq,req,status_array,ierr)
6218       do iii=1,ntask_cont_from
6219         iproc=itask_cont_from(iii)
6220         nn=ncont_recv(iii)
6221         if (lprn) then
6222         write (iout,*) "Received",nn," contacts from processor",iproc,
6223      &   " of CONT_FROM_COMM group"
6224         call flush(iout)
6225         do i=1,nn
6226           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6227         enddo
6228         call flush(iout)
6229         endif
6230         do i=1,nn
6231           ii=zapas_recv(1,i,iii)
6232 c Flag the received contacts to prevent double-counting
6233           jj=-zapas_recv(2,i,iii)
6234 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6235 c          call flush(iout)
6236           nnn=num_cont_hb(ii)+1
6237           num_cont_hb(ii)=nnn
6238           jcont_hb(nnn,ii)=jj
6239           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6240           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6241           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6242           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6243           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6244           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6245           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6246           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6247           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6248           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6249           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6250           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6251           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6252           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6253           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6254           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6255           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6256           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6257           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6258           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6259           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6260           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6261           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6262           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6263         enddo
6264       enddo
6265       call flush(iout)
6266       if (lprn) then
6267         write (iout,'(a)') 'Contact function values after receive:'
6268         do i=nnt,nct-2
6269           write (iout,'(2i3,50(1x,i3,f5.2))')
6270      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6271      &    j=1,num_cont_hb(i))
6272         enddo
6273         call flush(iout)
6274       endif
6275    30 continue
6276 #endif
6277       if (lprn) then
6278         write (iout,'(a)') 'Contact function values:'
6279         do i=nnt,nct-2
6280           write (iout,'(2i3,50(1x,i3,f5.2))')
6281      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6282      &    j=1,num_cont_hb(i))
6283         enddo
6284       endif
6285       ecorr=0.0D0
6286 C Remove the loop below after debugging !!!
6287       do i=nnt,nct
6288         do j=1,3
6289           gradcorr(j,i)=0.0D0
6290           gradxorr(j,i)=0.0D0
6291         enddo
6292       enddo
6293 C Calculate the local-electrostatic correlation terms
6294       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6295         i1=i+1
6296         num_conti=num_cont_hb(i)
6297         num_conti1=num_cont_hb(i+1)
6298         do jj=1,num_conti
6299           j=jcont_hb(jj,i)
6300           jp=iabs(j)
6301           do kk=1,num_conti1
6302             j1=jcont_hb(kk,i1)
6303             jp1=iabs(j1)
6304 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6305 c     &         ' jj=',jj,' kk=',kk
6306             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6307      &          .or. j.lt.0 .and. j1.gt.0) .and.
6308      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6309 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6310 C The system gains extra energy.
6311               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6312               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6313      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6314               n_corr=n_corr+1
6315             else if (j1.eq.j) then
6316 C Contacts I-J and I-(J+1) occur simultaneously.
6317 C The system loses extra energy.
6318 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6319             endif
6320           enddo ! kk
6321           do kk=1,num_conti
6322             j1=jcont_hb(kk,i)
6323 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6324 c    &         ' jj=',jj,' kk=',kk
6325             if (j1.eq.j+1) then
6326 C Contacts I-J and (I+1)-J occur simultaneously.
6327 C The system loses extra energy.
6328 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6329             endif ! j1==j+1
6330           enddo ! kk
6331         enddo ! jj
6332       enddo ! i
6333       return
6334       end
6335 c------------------------------------------------------------------------------
6336       subroutine add_hb_contact(ii,jj,itask)
6337       implicit real*8 (a-h,o-z)
6338       include "DIMENSIONS"
6339       include "COMMON.IOUNITS"
6340       integer max_cont
6341       integer max_dim
6342       parameter (max_cont=maxconts)
6343       parameter (max_dim=26)
6344       include "COMMON.CONTACTS"
6345       double precision zapas(max_dim,maxconts,max_fg_procs),
6346      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6347       common /przechowalnia/ zapas
6348       integer i,j,ii,jj,iproc,itask(4),nn
6349 c      write (iout,*) "itask",itask
6350       do i=1,2
6351         iproc=itask(i)
6352         if (iproc.gt.0) then
6353           do j=1,num_cont_hb(ii)
6354             jjc=jcont_hb(j,ii)
6355 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6356             if (jjc.eq.jj) then
6357               ncont_sent(iproc)=ncont_sent(iproc)+1
6358               nn=ncont_sent(iproc)
6359               zapas(1,nn,iproc)=ii
6360               zapas(2,nn,iproc)=jjc
6361               zapas(3,nn,iproc)=facont_hb(j,ii)
6362               zapas(4,nn,iproc)=ees0p(j,ii)
6363               zapas(5,nn,iproc)=ees0m(j,ii)
6364               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6365               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6366               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6367               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6368               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6369               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6370               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6371               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6372               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6373               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6374               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6375               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6376               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6377               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6378               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6379               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6380               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6381               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6382               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6383               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6384               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6385               exit
6386             endif
6387           enddo
6388         endif
6389       enddo
6390       return
6391       end
6392 c------------------------------------------------------------------------------
6393       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6394      &  n_corr1)
6395 C This subroutine calculates multi-body contributions to hydrogen-bonding
6396       implicit real*8 (a-h,o-z)
6397       include 'DIMENSIONS'
6398       include 'COMMON.IOUNITS'
6399 #ifdef MPI
6400       include "mpif.h"
6401       parameter (max_cont=maxconts)
6402       parameter (max_dim=70)
6403       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6404       double precision zapas(max_dim,maxconts,max_fg_procs),
6405      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6406       common /przechowalnia/ zapas
6407       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6408      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6409 #endif
6410       include 'COMMON.SETUP'
6411       include 'COMMON.FFIELD'
6412       include 'COMMON.DERIV'
6413       include 'COMMON.LOCAL'
6414       include 'COMMON.INTERACT'
6415       include 'COMMON.CONTACTS'
6416       include 'COMMON.CHAIN'
6417       include 'COMMON.CONTROL'
6418       double precision gx(3),gx1(3)
6419       integer num_cont_hb_old(maxres)
6420       logical lprn,ldone
6421       double precision eello4,eello5,eelo6,eello_turn6
6422       external eello4,eello5,eello6,eello_turn6
6423 C Set lprn=.true. for debugging
6424       lprn=.false.
6425       eturn6=0.0d0
6426 #ifdef MPI
6427       do i=1,nres
6428         num_cont_hb_old(i)=num_cont_hb(i)
6429       enddo
6430       n_corr=0
6431       n_corr1=0
6432       if (nfgtasks.le.1) goto 30
6433       if (lprn) then
6434         write (iout,'(a)') 'Contact function values before RECEIVE:'
6435         do i=nnt,nct-2
6436           write (iout,'(2i3,50(1x,i2,f5.2))')
6437      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6438      &    j=1,num_cont_hb(i))
6439         enddo
6440       endif
6441       call flush(iout)
6442       do i=1,ntask_cont_from
6443         ncont_recv(i)=0
6444       enddo
6445       do i=1,ntask_cont_to
6446         ncont_sent(i)=0
6447       enddo
6448 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6449 c     & ntask_cont_to
6450 C Make the list of contacts to send to send to other procesors
6451       do i=iturn3_start,iturn3_end
6452 c        write (iout,*) "make contact list turn3",i," num_cont",
6453 c     &    num_cont_hb(i)
6454         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6455       enddo
6456       do i=iturn4_start,iturn4_end
6457 c        write (iout,*) "make contact list turn4",i," num_cont",
6458 c     &   num_cont_hb(i)
6459         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6460       enddo
6461       do ii=1,nat_sent
6462         i=iat_sent(ii)
6463 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6464 c     &    num_cont_hb(i)
6465         do j=1,num_cont_hb(i)
6466         do k=1,4
6467           jjc=jcont_hb(j,i)
6468           iproc=iint_sent_local(k,jjc,ii)
6469 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6470           if (iproc.ne.0) then
6471             ncont_sent(iproc)=ncont_sent(iproc)+1
6472             nn=ncont_sent(iproc)
6473             zapas(1,nn,iproc)=i
6474             zapas(2,nn,iproc)=jjc
6475             zapas(3,nn,iproc)=d_cont(j,i)
6476             ind=3
6477             do kk=1,3
6478               ind=ind+1
6479               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6480             enddo
6481             do kk=1,2
6482               do ll=1,2
6483                 ind=ind+1
6484                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6485               enddo
6486             enddo
6487             do jj=1,5
6488               do kk=1,3
6489                 do ll=1,2
6490                   do mm=1,2
6491                     ind=ind+1
6492                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6493                   enddo
6494                 enddo
6495               enddo
6496             enddo
6497           endif
6498         enddo
6499         enddo
6500       enddo
6501       if (lprn) then
6502       write (iout,*)
6503      &  "Numbers of contacts to be sent to other processors",
6504      &  (ncont_sent(i),i=1,ntask_cont_to)
6505       write (iout,*) "Contacts sent"
6506       do ii=1,ntask_cont_to
6507         nn=ncont_sent(ii)
6508         iproc=itask_cont_to(ii)
6509         write (iout,*) nn," contacts to processor",iproc,
6510      &   " of CONT_TO_COMM group"
6511         do i=1,nn
6512           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6513         enddo
6514       enddo
6515       call flush(iout)
6516       endif
6517       CorrelType=477
6518       CorrelID=fg_rank+1
6519       CorrelType1=478
6520       CorrelID1=nfgtasks+fg_rank+1
6521       ireq=0
6522 C Receive the numbers of needed contacts from other processors
6523       do ii=1,ntask_cont_from
6524         iproc=itask_cont_from(ii)
6525         ireq=ireq+1
6526         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6527      &    FG_COMM,req(ireq),IERR)
6528       enddo
6529 c      write (iout,*) "IRECV ended"
6530 c      call flush(iout)
6531 C Send the number of contacts needed by other processors
6532       do ii=1,ntask_cont_to
6533         iproc=itask_cont_to(ii)
6534         ireq=ireq+1
6535         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6536      &    FG_COMM,req(ireq),IERR)
6537       enddo
6538 c      write (iout,*) "ISEND ended"
6539 c      write (iout,*) "number of requests (nn)",ireq
6540       call flush(iout)
6541       if (ireq.gt.0)
6542      &  call MPI_Waitall(ireq,req,status_array,ierr)
6543 c      write (iout,*)
6544 c     &  "Numbers of contacts to be received from other processors",
6545 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6546 c      call flush(iout)
6547 C Receive contacts
6548       ireq=0
6549       do ii=1,ntask_cont_from
6550         iproc=itask_cont_from(ii)
6551         nn=ncont_recv(ii)
6552 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6553 c     &   " of CONT_TO_COMM group"
6554         call flush(iout)
6555         if (nn.gt.0) then
6556           ireq=ireq+1
6557           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6558      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6559 c          write (iout,*) "ireq,req",ireq,req(ireq)
6560         endif
6561       enddo
6562 C Send the contacts to processors that need them
6563       do ii=1,ntask_cont_to
6564         iproc=itask_cont_to(ii)
6565         nn=ncont_sent(ii)
6566 c        write (iout,*) nn," contacts to processor",iproc,
6567 c     &   " of CONT_TO_COMM group"
6568         if (nn.gt.0) then
6569           ireq=ireq+1
6570           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6571      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6572 c          write (iout,*) "ireq,req",ireq,req(ireq)
6573 c          do i=1,nn
6574 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6575 c          enddo
6576         endif
6577       enddo
6578 c      write (iout,*) "number of requests (contacts)",ireq
6579 c      write (iout,*) "req",(req(i),i=1,4)
6580 c      call flush(iout)
6581       if (ireq.gt.0)
6582      & call MPI_Waitall(ireq,req,status_array,ierr)
6583       do iii=1,ntask_cont_from
6584         iproc=itask_cont_from(iii)
6585         nn=ncont_recv(iii)
6586         if (lprn) then
6587         write (iout,*) "Received",nn," contacts from processor",iproc,
6588      &   " of CONT_FROM_COMM group"
6589         call flush(iout)
6590         do i=1,nn
6591           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6592         enddo
6593         call flush(iout)
6594         endif
6595         do i=1,nn
6596           ii=zapas_recv(1,i,iii)
6597 c Flag the received contacts to prevent double-counting
6598           jj=-zapas_recv(2,i,iii)
6599 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6600 c          call flush(iout)
6601           nnn=num_cont_hb(ii)+1
6602           num_cont_hb(ii)=nnn
6603           jcont_hb(nnn,ii)=jj
6604           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6605           ind=3
6606           do kk=1,3
6607             ind=ind+1
6608             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6609           enddo
6610           do kk=1,2
6611             do ll=1,2
6612               ind=ind+1
6613               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6614             enddo
6615           enddo
6616           do jj=1,5
6617             do kk=1,3
6618               do ll=1,2
6619                 do mm=1,2
6620                   ind=ind+1
6621                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6622                 enddo
6623               enddo
6624             enddo
6625           enddo
6626         enddo
6627       enddo
6628       call flush(iout)
6629       if (lprn) then
6630         write (iout,'(a)') 'Contact function values after receive:'
6631         do i=nnt,nct-2
6632           write (iout,'(2i3,50(1x,i3,5f6.3))')
6633      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6634      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6635         enddo
6636         call flush(iout)
6637       endif
6638    30 continue
6639 #endif
6640       if (lprn) then
6641         write (iout,'(a)') 'Contact function values:'
6642         do i=nnt,nct-2
6643           write (iout,'(2i3,50(1x,i2,5f6.3))')
6644      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6645      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6646         enddo
6647       endif
6648       ecorr=0.0D0
6649       ecorr5=0.0d0
6650       ecorr6=0.0d0
6651 C Remove the loop below after debugging !!!
6652       do i=nnt,nct
6653         do j=1,3
6654           gradcorr(j,i)=0.0D0
6655           gradxorr(j,i)=0.0D0
6656         enddo
6657       enddo
6658 C Calculate the dipole-dipole interaction energies
6659       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6660       do i=iatel_s,iatel_e+1
6661         num_conti=num_cont_hb(i)
6662         do jj=1,num_conti
6663           j=jcont_hb(jj,i)
6664 #ifdef MOMENT
6665           call dipole(i,j,jj)
6666 #endif
6667         enddo
6668       enddo
6669       endif
6670 C Calculate the local-electrostatic correlation terms
6671 c                write (iout,*) "gradcorr5 in eello5 before loop"
6672 c                do iii=1,nres
6673 c                  write (iout,'(i5,3f10.5)')
6674 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6675 c                enddo
6676       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6677 c        write (iout,*) "corr loop i",i
6678         i1=i+1
6679         num_conti=num_cont_hb(i)
6680         num_conti1=num_cont_hb(i+1)
6681         do jj=1,num_conti
6682           j=jcont_hb(jj,i)
6683           jp=iabs(j)
6684           do kk=1,num_conti1
6685             j1=jcont_hb(kk,i1)
6686             jp1=iabs(j1)
6687 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6688 c     &         ' jj=',jj,' kk=',kk
6689 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6690             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6691      &          .or. j.lt.0 .and. j1.gt.0) .and.
6692      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6693 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6694 C The system gains extra energy.
6695               n_corr=n_corr+1
6696               sqd1=dsqrt(d_cont(jj,i))
6697               sqd2=dsqrt(d_cont(kk,i1))
6698               sred_geom = sqd1*sqd2
6699               IF (sred_geom.lt.cutoff_corr) THEN
6700                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6701      &            ekont,fprimcont)
6702 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6703 cd     &         ' jj=',jj,' kk=',kk
6704                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6705                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6706                 do l=1,3
6707                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6708                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6709                 enddo
6710                 n_corr1=n_corr1+1
6711 cd               write (iout,*) 'sred_geom=',sred_geom,
6712 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6713 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6714 cd               write (iout,*) "g_contij",g_contij
6715 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6716 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6717                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6718                 if (wcorr4.gt.0.0d0)
6719      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6720                   if (energy_dec.and.wcorr4.gt.0.0d0)
6721      1                 write (iout,'(a6,4i5,0pf7.3)')
6722      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6723 c                write (iout,*) "gradcorr5 before eello5"
6724 c                do iii=1,nres
6725 c                  write (iout,'(i5,3f10.5)')
6726 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6727 c                enddo
6728                 if (wcorr5.gt.0.0d0)
6729      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6730 c                write (iout,*) "gradcorr5 after eello5"
6731 c                do iii=1,nres
6732 c                  write (iout,'(i5,3f10.5)')
6733 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6734 c                enddo
6735                   if (energy_dec.and.wcorr5.gt.0.0d0)
6736      1                 write (iout,'(a6,4i5,0pf7.3)')
6737      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6738 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6739 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6740                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6741      &               .or. wturn6.eq.0.0d0))then
6742 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6743                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6744                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6745      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6746 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6747 cd     &            'ecorr6=',ecorr6
6748 cd                write (iout,'(4e15.5)') sred_geom,
6749 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6750 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6751 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6752                 else if (wturn6.gt.0.0d0
6753      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6754 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6755                   eturn6=eturn6+eello_turn6(i,jj,kk)
6756                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6757      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6758 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6759                 endif
6760               ENDIF
6761 1111          continue
6762             endif
6763           enddo ! kk
6764         enddo ! jj
6765       enddo ! i
6766       do i=1,nres
6767         num_cont_hb(i)=num_cont_hb_old(i)
6768       enddo
6769 c                write (iout,*) "gradcorr5 in eello5"
6770 c                do iii=1,nres
6771 c                  write (iout,'(i5,3f10.5)')
6772 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6773 c                enddo
6774       return
6775       end
6776 c------------------------------------------------------------------------------
6777       subroutine add_hb_contact_eello(ii,jj,itask)
6778       implicit real*8 (a-h,o-z)
6779       include "DIMENSIONS"
6780       include "COMMON.IOUNITS"
6781       integer max_cont
6782       integer max_dim
6783       parameter (max_cont=maxconts)
6784       parameter (max_dim=70)
6785       include "COMMON.CONTACTS"
6786       double precision zapas(max_dim,maxconts,max_fg_procs),
6787      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6788       common /przechowalnia/ zapas
6789       integer i,j,ii,jj,iproc,itask(4),nn
6790 c      write (iout,*) "itask",itask
6791       do i=1,2
6792         iproc=itask(i)
6793         if (iproc.gt.0) then
6794           do j=1,num_cont_hb(ii)
6795             jjc=jcont_hb(j,ii)
6796 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6797             if (jjc.eq.jj) then
6798               ncont_sent(iproc)=ncont_sent(iproc)+1
6799               nn=ncont_sent(iproc)
6800               zapas(1,nn,iproc)=ii
6801               zapas(2,nn,iproc)=jjc
6802               zapas(3,nn,iproc)=d_cont(j,ii)
6803               ind=3
6804               do kk=1,3
6805                 ind=ind+1
6806                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6807               enddo
6808               do kk=1,2
6809                 do ll=1,2
6810                   ind=ind+1
6811                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6812                 enddo
6813               enddo
6814               do jj=1,5
6815                 do kk=1,3
6816                   do ll=1,2
6817                     do mm=1,2
6818                       ind=ind+1
6819                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6820                     enddo
6821                   enddo
6822                 enddo
6823               enddo
6824               exit
6825             endif
6826           enddo
6827         endif
6828       enddo
6829       return
6830       end
6831 c------------------------------------------------------------------------------
6832       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6833       implicit real*8 (a-h,o-z)
6834       include 'DIMENSIONS'
6835       include 'COMMON.IOUNITS'
6836       include 'COMMON.DERIV'
6837       include 'COMMON.INTERACT'
6838       include 'COMMON.CONTACTS'
6839       double precision gx(3),gx1(3)
6840       logical lprn
6841       lprn=.false.
6842       eij=facont_hb(jj,i)
6843       ekl=facont_hb(kk,k)
6844       ees0pij=ees0p(jj,i)
6845       ees0pkl=ees0p(kk,k)
6846       ees0mij=ees0m(jj,i)
6847       ees0mkl=ees0m(kk,k)
6848       ekont=eij*ekl
6849       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6850 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6851 C Following 4 lines for diagnostics.
6852 cd    ees0pkl=0.0D0
6853 cd    ees0pij=1.0D0
6854 cd    ees0mkl=0.0D0
6855 cd    ees0mij=1.0D0
6856 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6857 c     & 'Contacts ',i,j,
6858 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6859 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6860 c     & 'gradcorr_long'
6861 C Calculate the multi-body contribution to energy.
6862 c      ecorr=ecorr+ekont*ees
6863 C Calculate multi-body contributions to the gradient.
6864       coeffpees0pij=coeffp*ees0pij
6865       coeffmees0mij=coeffm*ees0mij
6866       coeffpees0pkl=coeffp*ees0pkl
6867       coeffmees0mkl=coeffm*ees0mkl
6868       do ll=1,3
6869 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6870         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6871      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6872      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6873         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6874      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6875      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6876 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6877         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6878      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6879      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6880         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6881      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6882      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6883         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6884      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6885      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6886         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6887         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6888         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6889      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6890      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6891         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6892         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6893 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6894       enddo
6895 c      write (iout,*)
6896 cgrad      do m=i+1,j-1
6897 cgrad        do ll=1,3
6898 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6899 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6900 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6901 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6902 cgrad        enddo
6903 cgrad      enddo
6904 cgrad      do m=k+1,l-1
6905 cgrad        do ll=1,3
6906 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6907 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6908 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6909 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6910 cgrad        enddo
6911 cgrad      enddo
6912 c      write (iout,*) "ehbcorr",ekont*ees
6913       ehbcorr=ekont*ees
6914       return
6915       end
6916 #ifdef MOMENT
6917 C---------------------------------------------------------------------------
6918       subroutine dipole(i,j,jj)
6919       implicit real*8 (a-h,o-z)
6920       include 'DIMENSIONS'
6921       include 'COMMON.IOUNITS'
6922       include 'COMMON.CHAIN'
6923       include 'COMMON.FFIELD'
6924       include 'COMMON.DERIV'
6925       include 'COMMON.INTERACT'
6926       include 'COMMON.CONTACTS'
6927       include 'COMMON.TORSION'
6928       include 'COMMON.VAR'
6929       include 'COMMON.GEO'
6930       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6931      &  auxmat(2,2)
6932       iti1 = itortyp(itype(i+1))
6933       if (j.lt.nres-1) then
6934         itj1 = itortyp(itype(j+1))
6935       else
6936         itj1=ntortyp+1
6937       endif
6938       do iii=1,2
6939         dipi(iii,1)=Ub2(iii,i)
6940         dipderi(iii)=Ub2der(iii,i)
6941         dipi(iii,2)=b1(iii,iti1)
6942         dipj(iii,1)=Ub2(iii,j)
6943         dipderj(iii)=Ub2der(iii,j)
6944         dipj(iii,2)=b1(iii,itj1)
6945       enddo
6946       kkk=0
6947       do iii=1,2
6948         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6949         do jjj=1,2
6950           kkk=kkk+1
6951           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6952         enddo
6953       enddo
6954       do kkk=1,5
6955         do lll=1,3
6956           mmm=0
6957           do iii=1,2
6958             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6959      &        auxvec(1))
6960             do jjj=1,2
6961               mmm=mmm+1
6962               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6963             enddo
6964           enddo
6965         enddo
6966       enddo
6967       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6968       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6969       do iii=1,2
6970         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6971       enddo
6972       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6973       do iii=1,2
6974         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6975       enddo
6976       return
6977       end
6978 #endif
6979 C---------------------------------------------------------------------------
6980       subroutine calc_eello(i,j,k,l,jj,kk)
6981 C
6982 C This subroutine computes matrices and vectors needed to calculate
6983 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6984 C
6985       implicit real*8 (a-h,o-z)
6986       include 'DIMENSIONS'
6987       include 'COMMON.IOUNITS'
6988       include 'COMMON.CHAIN'
6989       include 'COMMON.DERIV'
6990       include 'COMMON.INTERACT'
6991       include 'COMMON.CONTACTS'
6992       include 'COMMON.TORSION'
6993       include 'COMMON.VAR'
6994       include 'COMMON.GEO'
6995       include 'COMMON.FFIELD'
6996       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6997      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6998       logical lprn
6999       common /kutas/ lprn
7000 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7001 cd     & ' jj=',jj,' kk=',kk
7002 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7003 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7004 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7005       do iii=1,2
7006         do jjj=1,2
7007           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7008           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7009         enddo
7010       enddo
7011       call transpose2(aa1(1,1),aa1t(1,1))
7012       call transpose2(aa2(1,1),aa2t(1,1))
7013       do kkk=1,5
7014         do lll=1,3
7015           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7016      &      aa1tder(1,1,lll,kkk))
7017           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7018      &      aa2tder(1,1,lll,kkk))
7019         enddo
7020       enddo
7021       if (l.eq.j+1) then
7022 C parallel orientation of the two CA-CA-CA frames.
7023         if (i.gt.1) then
7024           iti=itortyp(itype(i))
7025         else
7026           iti=ntortyp+1
7027         endif
7028         itk1=itortyp(itype(k+1))
7029         itj=itortyp(itype(j))
7030         if (l.lt.nres-1) then
7031           itl1=itortyp(itype(l+1))
7032         else
7033           itl1=ntortyp+1
7034         endif
7035 C A1 kernel(j+1) A2T
7036 cd        do iii=1,2
7037 cd          write (iout,'(3f10.5,5x,3f10.5)')
7038 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7039 cd        enddo
7040         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7041      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7042      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7043 C Following matrices are needed only for 6-th order cumulants
7044         IF (wcorr6.gt.0.0d0) THEN
7045         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7046      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7047      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7048         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7049      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7050      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7051      &   ADtEAderx(1,1,1,1,1,1))
7052         lprn=.false.
7053         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7054      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7055      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7056      &   ADtEA1derx(1,1,1,1,1,1))
7057         ENDIF
7058 C End 6-th order cumulants
7059 cd        lprn=.false.
7060 cd        if (lprn) then
7061 cd        write (2,*) 'In calc_eello6'
7062 cd        do iii=1,2
7063 cd          write (2,*) 'iii=',iii
7064 cd          do kkk=1,5
7065 cd            write (2,*) 'kkk=',kkk
7066 cd            do jjj=1,2
7067 cd              write (2,'(3(2f10.5),5x)')
7068 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7069 cd            enddo
7070 cd          enddo
7071 cd        enddo
7072 cd        endif
7073         call transpose2(EUgder(1,1,k),auxmat(1,1))
7074         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7075         call transpose2(EUg(1,1,k),auxmat(1,1))
7076         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7077         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7078         do iii=1,2
7079           do kkk=1,5
7080             do lll=1,3
7081               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7082      &          EAEAderx(1,1,lll,kkk,iii,1))
7083             enddo
7084           enddo
7085         enddo
7086 C A1T kernel(i+1) A2
7087         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7088      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7089      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7090 C Following matrices are needed only for 6-th order cumulants
7091         IF (wcorr6.gt.0.0d0) THEN
7092         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7093      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7094      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7095         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7096      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7097      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7098      &   ADtEAderx(1,1,1,1,1,2))
7099         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7100      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7101      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7102      &   ADtEA1derx(1,1,1,1,1,2))
7103         ENDIF
7104 C End 6-th order cumulants
7105         call transpose2(EUgder(1,1,l),auxmat(1,1))
7106         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7107         call transpose2(EUg(1,1,l),auxmat(1,1))
7108         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7109         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7110         do iii=1,2
7111           do kkk=1,5
7112             do lll=1,3
7113               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7114      &          EAEAderx(1,1,lll,kkk,iii,2))
7115             enddo
7116           enddo
7117         enddo
7118 C AEAb1 and AEAb2
7119 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7120 C They are needed only when the fifth- or the sixth-order cumulants are
7121 C indluded.
7122         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7123         call transpose2(AEA(1,1,1),auxmat(1,1))
7124         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7125         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7126         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7127         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7128         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7129         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7130         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7131         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7132         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7133         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7134         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7135         call transpose2(AEA(1,1,2),auxmat(1,1))
7136         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7137         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7138         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7139         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7140         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7141         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7142         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7143         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7144         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7145         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7146         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7147 C Calculate the Cartesian derivatives of the vectors.
7148         do iii=1,2
7149           do kkk=1,5
7150             do lll=1,3
7151               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7152               call matvec2(auxmat(1,1),b1(1,iti),
7153      &          AEAb1derx(1,lll,kkk,iii,1,1))
7154               call matvec2(auxmat(1,1),Ub2(1,i),
7155      &          AEAb2derx(1,lll,kkk,iii,1,1))
7156               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7157      &          AEAb1derx(1,lll,kkk,iii,2,1))
7158               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7159      &          AEAb2derx(1,lll,kkk,iii,2,1))
7160               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7161               call matvec2(auxmat(1,1),b1(1,itj),
7162      &          AEAb1derx(1,lll,kkk,iii,1,2))
7163               call matvec2(auxmat(1,1),Ub2(1,j),
7164      &          AEAb2derx(1,lll,kkk,iii,1,2))
7165               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7166      &          AEAb1derx(1,lll,kkk,iii,2,2))
7167               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7168      &          AEAb2derx(1,lll,kkk,iii,2,2))
7169             enddo
7170           enddo
7171         enddo
7172         ENDIF
7173 C End vectors
7174       else
7175 C Antiparallel orientation of the two CA-CA-CA frames.
7176         if (i.gt.1) then
7177           iti=itortyp(itype(i))
7178         else
7179           iti=ntortyp+1
7180         endif
7181         itk1=itortyp(itype(k+1))
7182         itl=itortyp(itype(l))
7183         itj=itortyp(itype(j))
7184         if (j.lt.nres-1) then
7185           itj1=itortyp(itype(j+1))
7186         else
7187           itj1=ntortyp+1
7188         endif
7189 C A2 kernel(j-1)T A1T
7190         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7191      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7192      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7193 C Following matrices are needed only for 6-th order cumulants
7194         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7195      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7196         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7197      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7198      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7199         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7200      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7201      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7202      &   ADtEAderx(1,1,1,1,1,1))
7203         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7204      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7205      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7206      &   ADtEA1derx(1,1,1,1,1,1))
7207         ENDIF
7208 C End 6-th order cumulants
7209         call transpose2(EUgder(1,1,k),auxmat(1,1))
7210         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7211         call transpose2(EUg(1,1,k),auxmat(1,1))
7212         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7213         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7214         do iii=1,2
7215           do kkk=1,5
7216             do lll=1,3
7217               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7218      &          EAEAderx(1,1,lll,kkk,iii,1))
7219             enddo
7220           enddo
7221         enddo
7222 C A2T kernel(i+1)T A1
7223         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7224      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7225      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7226 C Following matrices are needed only for 6-th order cumulants
7227         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7228      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7229         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7230      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7231      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7232         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7233      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7234      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7235      &   ADtEAderx(1,1,1,1,1,2))
7236         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7237      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7238      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7239      &   ADtEA1derx(1,1,1,1,1,2))
7240         ENDIF
7241 C End 6-th order cumulants
7242         call transpose2(EUgder(1,1,j),auxmat(1,1))
7243         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7244         call transpose2(EUg(1,1,j),auxmat(1,1))
7245         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7246         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7247         do iii=1,2
7248           do kkk=1,5
7249             do lll=1,3
7250               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7251      &          EAEAderx(1,1,lll,kkk,iii,2))
7252             enddo
7253           enddo
7254         enddo
7255 C AEAb1 and AEAb2
7256 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7257 C They are needed only when the fifth- or the sixth-order cumulants are
7258 C indluded.
7259         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7260      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7261         call transpose2(AEA(1,1,1),auxmat(1,1))
7262         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7263         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7264         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7265         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7266         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7267         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7268         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7269         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7270         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7271         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7272         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7273         call transpose2(AEA(1,1,2),auxmat(1,1))
7274         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7275         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7276         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7277         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7278         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7279         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7280         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7281         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7282         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7283         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7284         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7285 C Calculate the Cartesian derivatives of the vectors.
7286         do iii=1,2
7287           do kkk=1,5
7288             do lll=1,3
7289               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7290               call matvec2(auxmat(1,1),b1(1,iti),
7291      &          AEAb1derx(1,lll,kkk,iii,1,1))
7292               call matvec2(auxmat(1,1),Ub2(1,i),
7293      &          AEAb2derx(1,lll,kkk,iii,1,1))
7294               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7295      &          AEAb1derx(1,lll,kkk,iii,2,1))
7296               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7297      &          AEAb2derx(1,lll,kkk,iii,2,1))
7298               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7299               call matvec2(auxmat(1,1),b1(1,itl),
7300      &          AEAb1derx(1,lll,kkk,iii,1,2))
7301               call matvec2(auxmat(1,1),Ub2(1,l),
7302      &          AEAb2derx(1,lll,kkk,iii,1,2))
7303               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7304      &          AEAb1derx(1,lll,kkk,iii,2,2))
7305               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7306      &          AEAb2derx(1,lll,kkk,iii,2,2))
7307             enddo
7308           enddo
7309         enddo
7310         ENDIF
7311 C End vectors
7312       endif
7313       return
7314       end
7315 C---------------------------------------------------------------------------
7316       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7317      &  KK,KKderg,AKA,AKAderg,AKAderx)
7318       implicit none
7319       integer nderg
7320       logical transp
7321       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7322      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7323      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7324       integer iii,kkk,lll
7325       integer jjj,mmm
7326       logical lprn
7327       common /kutas/ lprn
7328       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7329       do iii=1,nderg
7330         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7331      &    AKAderg(1,1,iii))
7332       enddo
7333 cd      if (lprn) write (2,*) 'In kernel'
7334       do kkk=1,5
7335 cd        if (lprn) write (2,*) 'kkk=',kkk
7336         do lll=1,3
7337           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7338      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7339 cd          if (lprn) then
7340 cd            write (2,*) 'lll=',lll
7341 cd            write (2,*) 'iii=1'
7342 cd            do jjj=1,2
7343 cd              write (2,'(3(2f10.5),5x)')
7344 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7345 cd            enddo
7346 cd          endif
7347           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7348      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7349 cd          if (lprn) then
7350 cd            write (2,*) 'lll=',lll
7351 cd            write (2,*) 'iii=2'
7352 cd            do jjj=1,2
7353 cd              write (2,'(3(2f10.5),5x)')
7354 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7355 cd            enddo
7356 cd          endif
7357         enddo
7358       enddo
7359       return
7360       end
7361 C---------------------------------------------------------------------------
7362       double precision function eello4(i,j,k,l,jj,kk)
7363       implicit real*8 (a-h,o-z)
7364       include 'DIMENSIONS'
7365       include 'COMMON.IOUNITS'
7366       include 'COMMON.CHAIN'
7367       include 'COMMON.DERIV'
7368       include 'COMMON.INTERACT'
7369       include 'COMMON.CONTACTS'
7370       include 'COMMON.TORSION'
7371       include 'COMMON.VAR'
7372       include 'COMMON.GEO'
7373       double precision pizda(2,2),ggg1(3),ggg2(3)
7374 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7375 cd        eello4=0.0d0
7376 cd        return
7377 cd      endif
7378 cd      print *,'eello4:',i,j,k,l,jj,kk
7379 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7380 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7381 cold      eij=facont_hb(jj,i)
7382 cold      ekl=facont_hb(kk,k)
7383 cold      ekont=eij*ekl
7384       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7385 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7386       gcorr_loc(k-1)=gcorr_loc(k-1)
7387      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7388       if (l.eq.j+1) then
7389         gcorr_loc(l-1)=gcorr_loc(l-1)
7390      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7391       else
7392         gcorr_loc(j-1)=gcorr_loc(j-1)
7393      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7394       endif
7395       do iii=1,2
7396         do kkk=1,5
7397           do lll=1,3
7398             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7399      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7400 cd            derx(lll,kkk,iii)=0.0d0
7401           enddo
7402         enddo
7403       enddo
7404 cd      gcorr_loc(l-1)=0.0d0
7405 cd      gcorr_loc(j-1)=0.0d0
7406 cd      gcorr_loc(k-1)=0.0d0
7407 cd      eel4=1.0d0
7408 cd      write (iout,*)'Contacts have occurred for peptide groups',
7409 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7410 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7411       if (j.lt.nres-1) then
7412         j1=j+1
7413         j2=j-1
7414       else
7415         j1=j-1
7416         j2=j-2
7417       endif
7418       if (l.lt.nres-1) then
7419         l1=l+1
7420         l2=l-1
7421       else
7422         l1=l-1
7423         l2=l-2
7424       endif
7425       do ll=1,3
7426 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7427 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7428         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7429         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7430 cgrad        ghalf=0.5d0*ggg1(ll)
7431         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7432         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7433         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7434         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7435         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7436         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7437 cgrad        ghalf=0.5d0*ggg2(ll)
7438         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7439         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7440         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7441         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7442         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7443         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7444       enddo
7445 cgrad      do m=i+1,j-1
7446 cgrad        do ll=1,3
7447 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7448 cgrad        enddo
7449 cgrad      enddo
7450 cgrad      do m=k+1,l-1
7451 cgrad        do ll=1,3
7452 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7453 cgrad        enddo
7454 cgrad      enddo
7455 cgrad      do m=i+2,j2
7456 cgrad        do ll=1,3
7457 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7458 cgrad        enddo
7459 cgrad      enddo
7460 cgrad      do m=k+2,l2
7461 cgrad        do ll=1,3
7462 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7463 cgrad        enddo
7464 cgrad      enddo
7465 cd      do iii=1,nres-3
7466 cd        write (2,*) iii,gcorr_loc(iii)
7467 cd      enddo
7468       eello4=ekont*eel4
7469 cd      write (2,*) 'ekont',ekont
7470 cd      write (iout,*) 'eello4',ekont*eel4
7471       return
7472       end
7473 C---------------------------------------------------------------------------
7474       double precision function eello5(i,j,k,l,jj,kk)
7475       implicit real*8 (a-h,o-z)
7476       include 'DIMENSIONS'
7477       include 'COMMON.IOUNITS'
7478       include 'COMMON.CHAIN'
7479       include 'COMMON.DERIV'
7480       include 'COMMON.INTERACT'
7481       include 'COMMON.CONTACTS'
7482       include 'COMMON.TORSION'
7483       include 'COMMON.VAR'
7484       include 'COMMON.GEO'
7485       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7486       double precision ggg1(3),ggg2(3)
7487 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7488 C                                                                              C
7489 C                            Parallel chains                                   C
7490 C                                                                              C
7491 C          o             o                   o             o                   C
7492 C         /l\           / \             \   / \           / \   /              C
7493 C        /   \         /   \             \ /   \         /   \ /               C
7494 C       j| o |l1       | o |              o| o |         | o |o                C
7495 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7496 C      \i/   \         /   \ /             /   \         /   \                 C
7497 C       o    k1             o                                                  C
7498 C         (I)          (II)                (III)          (IV)                 C
7499 C                                                                              C
7500 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7501 C                                                                              C
7502 C                            Antiparallel chains                               C
7503 C                                                                              C
7504 C          o             o                   o             o                   C
7505 C         /j\           / \             \   / \           / \   /              C
7506 C        /   \         /   \             \ /   \         /   \ /               C
7507 C      j1| o |l        | o |              o| o |         | o |o                C
7508 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7509 C      \i/   \         /   \ /             /   \         /   \                 C
7510 C       o     k1            o                                                  C
7511 C         (I)          (II)                (III)          (IV)                 C
7512 C                                                                              C
7513 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7514 C                                                                              C
7515 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7516 C                                                                              C
7517 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7518 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7519 cd        eello5=0.0d0
7520 cd        return
7521 cd      endif
7522 cd      write (iout,*)
7523 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7524 cd     &   ' and',k,l
7525       itk=itortyp(itype(k))
7526       itl=itortyp(itype(l))
7527       itj=itortyp(itype(j))
7528       eello5_1=0.0d0
7529       eello5_2=0.0d0
7530       eello5_3=0.0d0
7531       eello5_4=0.0d0
7532 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7533 cd     &   eel5_3_num,eel5_4_num)
7534       do iii=1,2
7535         do kkk=1,5
7536           do lll=1,3
7537             derx(lll,kkk,iii)=0.0d0
7538           enddo
7539         enddo
7540       enddo
7541 cd      eij=facont_hb(jj,i)
7542 cd      ekl=facont_hb(kk,k)
7543 cd      ekont=eij*ekl
7544 cd      write (iout,*)'Contacts have occurred for peptide groups',
7545 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7546 cd      goto 1111
7547 C Contribution from the graph I.
7548 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7549 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7550       call transpose2(EUg(1,1,k),auxmat(1,1))
7551       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7552       vv(1)=pizda(1,1)-pizda(2,2)
7553       vv(2)=pizda(1,2)+pizda(2,1)
7554       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7555      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7556 C Explicit gradient in virtual-dihedral angles.
7557       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7558      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7559      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7560       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7561       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7562       vv(1)=pizda(1,1)-pizda(2,2)
7563       vv(2)=pizda(1,2)+pizda(2,1)
7564       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7565      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7566      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7567       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7568       vv(1)=pizda(1,1)-pizda(2,2)
7569       vv(2)=pizda(1,2)+pizda(2,1)
7570       if (l.eq.j+1) then
7571         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7572      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7573      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7574       else
7575         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7576      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7577      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7578       endif
7579 C Cartesian gradient
7580       do iii=1,2
7581         do kkk=1,5
7582           do lll=1,3
7583             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7584      &        pizda(1,1))
7585             vv(1)=pizda(1,1)-pizda(2,2)
7586             vv(2)=pizda(1,2)+pizda(2,1)
7587             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7588      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7589      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7590           enddo
7591         enddo
7592       enddo
7593 c      goto 1112
7594 c1111  continue
7595 C Contribution from graph II
7596       call transpose2(EE(1,1,itk),auxmat(1,1))
7597       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7598       vv(1)=pizda(1,1)+pizda(2,2)
7599       vv(2)=pizda(2,1)-pizda(1,2)
7600       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7601      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7602 C Explicit gradient in virtual-dihedral angles.
7603       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7604      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7605       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7606       vv(1)=pizda(1,1)+pizda(2,2)
7607       vv(2)=pizda(2,1)-pizda(1,2)
7608       if (l.eq.j+1) then
7609         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7610      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7611      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7612       else
7613         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7614      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7615      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7616       endif
7617 C Cartesian gradient
7618       do iii=1,2
7619         do kkk=1,5
7620           do lll=1,3
7621             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7622      &        pizda(1,1))
7623             vv(1)=pizda(1,1)+pizda(2,2)
7624             vv(2)=pizda(2,1)-pizda(1,2)
7625             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7626      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7627      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7628           enddo
7629         enddo
7630       enddo
7631 cd      goto 1112
7632 cd1111  continue
7633       if (l.eq.j+1) then
7634 cd        goto 1110
7635 C Parallel orientation
7636 C Contribution from graph III
7637         call transpose2(EUg(1,1,l),auxmat(1,1))
7638         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7639         vv(1)=pizda(1,1)-pizda(2,2)
7640         vv(2)=pizda(1,2)+pizda(2,1)
7641         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7642      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7643 C Explicit gradient in virtual-dihedral angles.
7644         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7645      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7646      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7647         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7648         vv(1)=pizda(1,1)-pizda(2,2)
7649         vv(2)=pizda(1,2)+pizda(2,1)
7650         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7651      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7652      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7653         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7654         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7655         vv(1)=pizda(1,1)-pizda(2,2)
7656         vv(2)=pizda(1,2)+pizda(2,1)
7657         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7658      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7659      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7660 C Cartesian gradient
7661         do iii=1,2
7662           do kkk=1,5
7663             do lll=1,3
7664               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7665      &          pizda(1,1))
7666               vv(1)=pizda(1,1)-pizda(2,2)
7667               vv(2)=pizda(1,2)+pizda(2,1)
7668               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7669      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7670      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7671             enddo
7672           enddo
7673         enddo
7674 cd        goto 1112
7675 C Contribution from graph IV
7676 cd1110    continue
7677         call transpose2(EE(1,1,itl),auxmat(1,1))
7678         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7679         vv(1)=pizda(1,1)+pizda(2,2)
7680         vv(2)=pizda(2,1)-pizda(1,2)
7681         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7682      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7683 C Explicit gradient in virtual-dihedral angles.
7684         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7685      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7686         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7687         vv(1)=pizda(1,1)+pizda(2,2)
7688         vv(2)=pizda(2,1)-pizda(1,2)
7689         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7690      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7691      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7692 C Cartesian gradient
7693         do iii=1,2
7694           do kkk=1,5
7695             do lll=1,3
7696               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7697      &          pizda(1,1))
7698               vv(1)=pizda(1,1)+pizda(2,2)
7699               vv(2)=pizda(2,1)-pizda(1,2)
7700               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7701      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7702      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7703             enddo
7704           enddo
7705         enddo
7706       else
7707 C Antiparallel orientation
7708 C Contribution from graph III
7709 c        goto 1110
7710         call transpose2(EUg(1,1,j),auxmat(1,1))
7711         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7712         vv(1)=pizda(1,1)-pizda(2,2)
7713         vv(2)=pizda(1,2)+pizda(2,1)
7714         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7715      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7716 C Explicit gradient in virtual-dihedral angles.
7717         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7718      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7719      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7720         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7721         vv(1)=pizda(1,1)-pizda(2,2)
7722         vv(2)=pizda(1,2)+pizda(2,1)
7723         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7724      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7725      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7726         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7727         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7728         vv(1)=pizda(1,1)-pizda(2,2)
7729         vv(2)=pizda(1,2)+pizda(2,1)
7730         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7731      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7732      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7733 C Cartesian gradient
7734         do iii=1,2
7735           do kkk=1,5
7736             do lll=1,3
7737               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7738      &          pizda(1,1))
7739               vv(1)=pizda(1,1)-pizda(2,2)
7740               vv(2)=pizda(1,2)+pizda(2,1)
7741               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7742      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7743      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7744             enddo
7745           enddo
7746         enddo
7747 cd        goto 1112
7748 C Contribution from graph IV
7749 1110    continue
7750         call transpose2(EE(1,1,itj),auxmat(1,1))
7751         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7752         vv(1)=pizda(1,1)+pizda(2,2)
7753         vv(2)=pizda(2,1)-pizda(1,2)
7754         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7755      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7756 C Explicit gradient in virtual-dihedral angles.
7757         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7758      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7759         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7760         vv(1)=pizda(1,1)+pizda(2,2)
7761         vv(2)=pizda(2,1)-pizda(1,2)
7762         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7763      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7764      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7765 C Cartesian gradient
7766         do iii=1,2
7767           do kkk=1,5
7768             do lll=1,3
7769               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7770      &          pizda(1,1))
7771               vv(1)=pizda(1,1)+pizda(2,2)
7772               vv(2)=pizda(2,1)-pizda(1,2)
7773               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7774      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7775      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7776             enddo
7777           enddo
7778         enddo
7779       endif
7780 1112  continue
7781       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7782 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7783 cd        write (2,*) 'ijkl',i,j,k,l
7784 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7785 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7786 cd      endif
7787 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7788 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7789 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7790 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7791       if (j.lt.nres-1) then
7792         j1=j+1
7793         j2=j-1
7794       else
7795         j1=j-1
7796         j2=j-2
7797       endif
7798       if (l.lt.nres-1) then
7799         l1=l+1
7800         l2=l-1
7801       else
7802         l1=l-1
7803         l2=l-2
7804       endif
7805 cd      eij=1.0d0
7806 cd      ekl=1.0d0
7807 cd      ekont=1.0d0
7808 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7809 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7810 C        summed up outside the subrouine as for the other subroutines
7811 C        handling long-range interactions. The old code is commented out
7812 C        with "cgrad" to keep track of changes.
7813       do ll=1,3
7814 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7815 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7816         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7817         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7818 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7819 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7820 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7821 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7822 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7823 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7824 c     &   gradcorr5ij,
7825 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7826 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7827 cgrad        ghalf=0.5d0*ggg1(ll)
7828 cd        ghalf=0.0d0
7829         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7830         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7831         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7832         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7833         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7834         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7835 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7836 cgrad        ghalf=0.5d0*ggg2(ll)
7837 cd        ghalf=0.0d0
7838         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7839         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7840         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7841         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7842         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7843         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7844       enddo
7845 cd      goto 1112
7846 cgrad      do m=i+1,j-1
7847 cgrad        do ll=1,3
7848 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7849 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7850 cgrad        enddo
7851 cgrad      enddo
7852 cgrad      do m=k+1,l-1
7853 cgrad        do ll=1,3
7854 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7855 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7856 cgrad        enddo
7857 cgrad      enddo
7858 c1112  continue
7859 cgrad      do m=i+2,j2
7860 cgrad        do ll=1,3
7861 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7862 cgrad        enddo
7863 cgrad      enddo
7864 cgrad      do m=k+2,l2
7865 cgrad        do ll=1,3
7866 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7867 cgrad        enddo
7868 cgrad      enddo
7869 cd      do iii=1,nres-3
7870 cd        write (2,*) iii,g_corr5_loc(iii)
7871 cd      enddo
7872       eello5=ekont*eel5
7873 cd      write (2,*) 'ekont',ekont
7874 cd      write (iout,*) 'eello5',ekont*eel5
7875       return
7876       end
7877 c--------------------------------------------------------------------------
7878       double precision function eello6(i,j,k,l,jj,kk)
7879       implicit real*8 (a-h,o-z)
7880       include 'DIMENSIONS'
7881       include 'COMMON.IOUNITS'
7882       include 'COMMON.CHAIN'
7883       include 'COMMON.DERIV'
7884       include 'COMMON.INTERACT'
7885       include 'COMMON.CONTACTS'
7886       include 'COMMON.TORSION'
7887       include 'COMMON.VAR'
7888       include 'COMMON.GEO'
7889       include 'COMMON.FFIELD'
7890       double precision ggg1(3),ggg2(3)
7891 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7892 cd        eello6=0.0d0
7893 cd        return
7894 cd      endif
7895 cd      write (iout,*)
7896 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7897 cd     &   ' and',k,l
7898       eello6_1=0.0d0
7899       eello6_2=0.0d0
7900       eello6_3=0.0d0
7901       eello6_4=0.0d0
7902       eello6_5=0.0d0
7903       eello6_6=0.0d0
7904 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7905 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7906       do iii=1,2
7907         do kkk=1,5
7908           do lll=1,3
7909             derx(lll,kkk,iii)=0.0d0
7910           enddo
7911         enddo
7912       enddo
7913 cd      eij=facont_hb(jj,i)
7914 cd      ekl=facont_hb(kk,k)
7915 cd      ekont=eij*ekl
7916 cd      eij=1.0d0
7917 cd      ekl=1.0d0
7918 cd      ekont=1.0d0
7919       if (l.eq.j+1) then
7920         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7921         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7922         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7923         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7924         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7925         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7926       else
7927         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7928         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7929         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7930         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7931         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7932           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7933         else
7934           eello6_5=0.0d0
7935         endif
7936         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7937       endif
7938 C If turn contributions are considered, they will be handled separately.
7939       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7940 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7941 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7942 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7943 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7944 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7945 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7946 cd      goto 1112
7947       if (j.lt.nres-1) then
7948         j1=j+1
7949         j2=j-1
7950       else
7951         j1=j-1
7952         j2=j-2
7953       endif
7954       if (l.lt.nres-1) then
7955         l1=l+1
7956         l2=l-1
7957       else
7958         l1=l-1
7959         l2=l-2
7960       endif
7961       do ll=1,3
7962 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7963 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7964 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7965 cgrad        ghalf=0.5d0*ggg1(ll)
7966 cd        ghalf=0.0d0
7967         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7968         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7969         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7970         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7971         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7972         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7973         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7974         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7975 cgrad        ghalf=0.5d0*ggg2(ll)
7976 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7977 cd        ghalf=0.0d0
7978         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7979         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7980         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7981         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7982         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7983         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7984       enddo
7985 cd      goto 1112
7986 cgrad      do m=i+1,j-1
7987 cgrad        do ll=1,3
7988 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7989 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7990 cgrad        enddo
7991 cgrad      enddo
7992 cgrad      do m=k+1,l-1
7993 cgrad        do ll=1,3
7994 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7995 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7996 cgrad        enddo
7997 cgrad      enddo
7998 cgrad1112  continue
7999 cgrad      do m=i+2,j2
8000 cgrad        do ll=1,3
8001 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8002 cgrad        enddo
8003 cgrad      enddo
8004 cgrad      do m=k+2,l2
8005 cgrad        do ll=1,3
8006 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8007 cgrad        enddo
8008 cgrad      enddo
8009 cd      do iii=1,nres-3
8010 cd        write (2,*) iii,g_corr6_loc(iii)
8011 cd      enddo
8012       eello6=ekont*eel6
8013 cd      write (2,*) 'ekont',ekont
8014 cd      write (iout,*) 'eello6',ekont*eel6
8015       return
8016       end
8017 c--------------------------------------------------------------------------
8018       double precision function eello6_graph1(i,j,k,l,imat,swap)
8019       implicit real*8 (a-h,o-z)
8020       include 'DIMENSIONS'
8021       include 'COMMON.IOUNITS'
8022       include 'COMMON.CHAIN'
8023       include 'COMMON.DERIV'
8024       include 'COMMON.INTERACT'
8025       include 'COMMON.CONTACTS'
8026       include 'COMMON.TORSION'
8027       include 'COMMON.VAR'
8028       include 'COMMON.GEO'
8029       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8030       logical swap
8031       logical lprn
8032       common /kutas/ lprn
8033 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8034 C
8035 C      Parallel       Antiparallel
8036 C
8037 C          o             o
8038 C         /l\           /j\
8039 C        /   \         /   \
8040 C       /| o |         | o |\
8041 C     \ j|/k\|  /   \  |/k\|l /
8042 C      \ /   \ /     \ /   \ /
8043 C       o     o       o     o
8044 C       i             i
8045 C
8046 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8047       itk=itortyp(itype(k))
8048       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8049       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8050       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8051       call transpose2(EUgC(1,1,k),auxmat(1,1))
8052       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8053       vv1(1)=pizda1(1,1)-pizda1(2,2)
8054       vv1(2)=pizda1(1,2)+pizda1(2,1)
8055       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8056       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8057       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8058       s5=scalar2(vv(1),Dtobr2(1,i))
8059 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8060       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8061       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8062      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8063      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8064      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8065      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8066      & +scalar2(vv(1),Dtobr2der(1,i)))
8067       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8068       vv1(1)=pizda1(1,1)-pizda1(2,2)
8069       vv1(2)=pizda1(1,2)+pizda1(2,1)
8070       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8071       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8072       if (l.eq.j+1) then
8073         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8074      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8075      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8076      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8077      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8078       else
8079         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8080      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8081      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8082      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8083      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8084       endif
8085       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8086       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8087       vv1(1)=pizda1(1,1)-pizda1(2,2)
8088       vv1(2)=pizda1(1,2)+pizda1(2,1)
8089       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8090      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8091      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8092      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8093       do iii=1,2
8094         if (swap) then
8095           ind=3-iii
8096         else
8097           ind=iii
8098         endif
8099         do kkk=1,5
8100           do lll=1,3
8101             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8102             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8103             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8104             call transpose2(EUgC(1,1,k),auxmat(1,1))
8105             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8106      &        pizda1(1,1))
8107             vv1(1)=pizda1(1,1)-pizda1(2,2)
8108             vv1(2)=pizda1(1,2)+pizda1(2,1)
8109             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8110             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8111      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8112             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8113      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8114             s5=scalar2(vv(1),Dtobr2(1,i))
8115             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8116           enddo
8117         enddo
8118       enddo
8119       return
8120       end
8121 c----------------------------------------------------------------------------
8122       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8123       implicit real*8 (a-h,o-z)
8124       include 'DIMENSIONS'
8125       include 'COMMON.IOUNITS'
8126       include 'COMMON.CHAIN'
8127       include 'COMMON.DERIV'
8128       include 'COMMON.INTERACT'
8129       include 'COMMON.CONTACTS'
8130       include 'COMMON.TORSION'
8131       include 'COMMON.VAR'
8132       include 'COMMON.GEO'
8133       logical swap
8134       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8135      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8136       logical lprn
8137       common /kutas/ lprn
8138 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8139 C
8140 C      Parallel       Antiparallel
8141 C
8142 C          o             o
8143 C     \   /l\           /j\   /
8144 C      \ /   \         /   \ /
8145 C       o| o |         | o |o
8146 C     \ j|/k\|      \  |/k\|l
8147 C      \ /   \       \ /   \
8148 C       o             o
8149 C       i             i
8150 C
8151 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8152 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8153 C AL 7/4/01 s1 would occur in the sixth-order moment,
8154 C           but not in a cluster cumulant
8155 #ifdef MOMENT
8156       s1=dip(1,jj,i)*dip(1,kk,k)
8157 #endif
8158       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8159       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8160       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8161       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8162       call transpose2(EUg(1,1,k),auxmat(1,1))
8163       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8164       vv(1)=pizda(1,1)-pizda(2,2)
8165       vv(2)=pizda(1,2)+pizda(2,1)
8166       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8167 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8168 #ifdef MOMENT
8169       eello6_graph2=-(s1+s2+s3+s4)
8170 #else
8171       eello6_graph2=-(s2+s3+s4)
8172 #endif
8173 c      eello6_graph2=-s3
8174 C Derivatives in gamma(i-1)
8175       if (i.gt.1) then
8176 #ifdef MOMENT
8177         s1=dipderg(1,jj,i)*dip(1,kk,k)
8178 #endif
8179         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8180         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8181         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8182         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8183 #ifdef MOMENT
8184         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8185 #else
8186         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8187 #endif
8188 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8189       endif
8190 C Derivatives in gamma(k-1)
8191 #ifdef MOMENT
8192       s1=dip(1,jj,i)*dipderg(1,kk,k)
8193 #endif
8194       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8195       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8196       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8197       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8198       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8199       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8200       vv(1)=pizda(1,1)-pizda(2,2)
8201       vv(2)=pizda(1,2)+pizda(2,1)
8202       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8203 #ifdef MOMENT
8204       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8205 #else
8206       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8207 #endif
8208 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8209 C Derivatives in gamma(j-1) or gamma(l-1)
8210       if (j.gt.1) then
8211 #ifdef MOMENT
8212         s1=dipderg(3,jj,i)*dip(1,kk,k)
8213 #endif
8214         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8215         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8216         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8217         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8218         vv(1)=pizda(1,1)-pizda(2,2)
8219         vv(2)=pizda(1,2)+pizda(2,1)
8220         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8221 #ifdef MOMENT
8222         if (swap) then
8223           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8224         else
8225           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8226         endif
8227 #endif
8228         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8229 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8230       endif
8231 C Derivatives in gamma(l-1) or gamma(j-1)
8232       if (l.gt.1) then
8233 #ifdef MOMENT
8234         s1=dip(1,jj,i)*dipderg(3,kk,k)
8235 #endif
8236         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8237         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8238         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8239         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8240         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8241         vv(1)=pizda(1,1)-pizda(2,2)
8242         vv(2)=pizda(1,2)+pizda(2,1)
8243         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8244 #ifdef MOMENT
8245         if (swap) then
8246           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8247         else
8248           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8249         endif
8250 #endif
8251         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8252 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8253       endif
8254 C Cartesian derivatives.
8255       if (lprn) then
8256         write (2,*) 'In eello6_graph2'
8257         do iii=1,2
8258           write (2,*) 'iii=',iii
8259           do kkk=1,5
8260             write (2,*) 'kkk=',kkk
8261             do jjj=1,2
8262               write (2,'(3(2f10.5),5x)')
8263      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8264             enddo
8265           enddo
8266         enddo
8267       endif
8268       do iii=1,2
8269         do kkk=1,5
8270           do lll=1,3
8271 #ifdef MOMENT
8272             if (iii.eq.1) then
8273               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8274             else
8275               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8276             endif
8277 #endif
8278             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8279      &        auxvec(1))
8280             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8281             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8282      &        auxvec(1))
8283             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8284             call transpose2(EUg(1,1,k),auxmat(1,1))
8285             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8286      &        pizda(1,1))
8287             vv(1)=pizda(1,1)-pizda(2,2)
8288             vv(2)=pizda(1,2)+pizda(2,1)
8289             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8290 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8291 #ifdef MOMENT
8292             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8293 #else
8294             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8295 #endif
8296             if (swap) then
8297               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8298             else
8299               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8300             endif
8301           enddo
8302         enddo
8303       enddo
8304       return
8305       end
8306 c----------------------------------------------------------------------------
8307       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8308       implicit real*8 (a-h,o-z)
8309       include 'DIMENSIONS'
8310       include 'COMMON.IOUNITS'
8311       include 'COMMON.CHAIN'
8312       include 'COMMON.DERIV'
8313       include 'COMMON.INTERACT'
8314       include 'COMMON.CONTACTS'
8315       include 'COMMON.TORSION'
8316       include 'COMMON.VAR'
8317       include 'COMMON.GEO'
8318       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8319       logical swap
8320 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8321 C
8322 C      Parallel       Antiparallel
8323 C
8324 C          o             o
8325 C         /l\   /   \   /j\
8326 C        /   \ /     \ /   \
8327 C       /| o |o       o| o |\
8328 C       j|/k\|  /      |/k\|l /
8329 C        /   \ /       /   \ /
8330 C       /     o       /     o
8331 C       i             i
8332 C
8333 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8334 C
8335 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8336 C           energy moment and not to the cluster cumulant.
8337       iti=itortyp(itype(i))
8338       if (j.lt.nres-1) then
8339         itj1=itortyp(itype(j+1))
8340       else
8341         itj1=ntortyp+1
8342       endif
8343       itk=itortyp(itype(k))
8344       itk1=itortyp(itype(k+1))
8345       if (l.lt.nres-1) then
8346         itl1=itortyp(itype(l+1))
8347       else
8348         itl1=ntortyp+1
8349       endif
8350 #ifdef MOMENT
8351       s1=dip(4,jj,i)*dip(4,kk,k)
8352 #endif
8353       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8354       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8355       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8356       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8357       call transpose2(EE(1,1,itk),auxmat(1,1))
8358       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8359       vv(1)=pizda(1,1)+pizda(2,2)
8360       vv(2)=pizda(2,1)-pizda(1,2)
8361       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8362 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8363 cd     & "sum",-(s2+s3+s4)
8364 #ifdef MOMENT
8365       eello6_graph3=-(s1+s2+s3+s4)
8366 #else
8367       eello6_graph3=-(s2+s3+s4)
8368 #endif
8369 c      eello6_graph3=-s4
8370 C Derivatives in gamma(k-1)
8371       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8372       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8373       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8374       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8375 C Derivatives in gamma(l-1)
8376       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8377       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8378       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8379       vv(1)=pizda(1,1)+pizda(2,2)
8380       vv(2)=pizda(2,1)-pizda(1,2)
8381       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8382       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8383 C Cartesian derivatives.
8384       do iii=1,2
8385         do kkk=1,5
8386           do lll=1,3
8387 #ifdef MOMENT
8388             if (iii.eq.1) then
8389               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8390             else
8391               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8392             endif
8393 #endif
8394             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8395      &        auxvec(1))
8396             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8397             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8398      &        auxvec(1))
8399             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8400             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8401      &        pizda(1,1))
8402             vv(1)=pizda(1,1)+pizda(2,2)
8403             vv(2)=pizda(2,1)-pizda(1,2)
8404             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8405 #ifdef MOMENT
8406             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8407 #else
8408             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8409 #endif
8410             if (swap) then
8411               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8412             else
8413               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8414             endif
8415 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8416           enddo
8417         enddo
8418       enddo
8419       return
8420       end
8421 c----------------------------------------------------------------------------
8422       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8423       implicit real*8 (a-h,o-z)
8424       include 'DIMENSIONS'
8425       include 'COMMON.IOUNITS'
8426       include 'COMMON.CHAIN'
8427       include 'COMMON.DERIV'
8428       include 'COMMON.INTERACT'
8429       include 'COMMON.CONTACTS'
8430       include 'COMMON.TORSION'
8431       include 'COMMON.VAR'
8432       include 'COMMON.GEO'
8433       include 'COMMON.FFIELD'
8434       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8435      & auxvec1(2),auxmat1(2,2)
8436       logical swap
8437 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8438 C
8439 C      Parallel       Antiparallel
8440 C
8441 C          o             o
8442 C         /l\   /   \   /j\
8443 C        /   \ /     \ /   \
8444 C       /| o |o       o| o |\
8445 C     \ j|/k\|      \  |/k\|l
8446 C      \ /   \       \ /   \
8447 C       o     \       o     \
8448 C       i             i
8449 C
8450 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8451 C
8452 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8453 C           energy moment and not to the cluster cumulant.
8454 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8455       iti=itortyp(itype(i))
8456       itj=itortyp(itype(j))
8457       if (j.lt.nres-1) then
8458         itj1=itortyp(itype(j+1))
8459       else
8460         itj1=ntortyp+1
8461       endif
8462       itk=itortyp(itype(k))
8463       if (k.lt.nres-1) then
8464         itk1=itortyp(itype(k+1))
8465       else
8466         itk1=ntortyp+1
8467       endif
8468       itl=itortyp(itype(l))
8469       if (l.lt.nres-1) then
8470         itl1=itortyp(itype(l+1))
8471       else
8472         itl1=ntortyp+1
8473       endif
8474 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8475 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8476 cd     & ' itl',itl,' itl1',itl1
8477 #ifdef MOMENT
8478       if (imat.eq.1) then
8479         s1=dip(3,jj,i)*dip(3,kk,k)
8480       else
8481         s1=dip(2,jj,j)*dip(2,kk,l)
8482       endif
8483 #endif
8484       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8485       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8486       if (j.eq.l+1) then
8487         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8488         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8489       else
8490         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8491         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8492       endif
8493       call transpose2(EUg(1,1,k),auxmat(1,1))
8494       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8495       vv(1)=pizda(1,1)-pizda(2,2)
8496       vv(2)=pizda(2,1)+pizda(1,2)
8497       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8498 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8499 #ifdef MOMENT
8500       eello6_graph4=-(s1+s2+s3+s4)
8501 #else
8502       eello6_graph4=-(s2+s3+s4)
8503 #endif
8504 C Derivatives in gamma(i-1)
8505       if (i.gt.1) then
8506 #ifdef MOMENT
8507         if (imat.eq.1) then
8508           s1=dipderg(2,jj,i)*dip(3,kk,k)
8509         else
8510           s1=dipderg(4,jj,j)*dip(2,kk,l)
8511         endif
8512 #endif
8513         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8514         if (j.eq.l+1) then
8515           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8516           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8517         else
8518           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8519           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8520         endif
8521         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8522         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8523 cd          write (2,*) 'turn6 derivatives'
8524 #ifdef MOMENT
8525           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8526 #else
8527           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8528 #endif
8529         else
8530 #ifdef MOMENT
8531           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8532 #else
8533           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8534 #endif
8535         endif
8536       endif
8537 C Derivatives in gamma(k-1)
8538 #ifdef MOMENT
8539       if (imat.eq.1) then
8540         s1=dip(3,jj,i)*dipderg(2,kk,k)
8541       else
8542         s1=dip(2,jj,j)*dipderg(4,kk,l)
8543       endif
8544 #endif
8545       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8546       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8547       if (j.eq.l+1) then
8548         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8549         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8550       else
8551         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8552         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8553       endif
8554       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8555       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8556       vv(1)=pizda(1,1)-pizda(2,2)
8557       vv(2)=pizda(2,1)+pizda(1,2)
8558       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8559       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8560 #ifdef MOMENT
8561         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8562 #else
8563         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8564 #endif
8565       else
8566 #ifdef MOMENT
8567         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8568 #else
8569         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8570 #endif
8571       endif
8572 C Derivatives in gamma(j-1) or gamma(l-1)
8573       if (l.eq.j+1 .and. l.gt.1) then
8574         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8575         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8576         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8577         vv(1)=pizda(1,1)-pizda(2,2)
8578         vv(2)=pizda(2,1)+pizda(1,2)
8579         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8580         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8581       else if (j.gt.1) then
8582         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8583         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8584         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8585         vv(1)=pizda(1,1)-pizda(2,2)
8586         vv(2)=pizda(2,1)+pizda(1,2)
8587         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8588         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8589           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8590         else
8591           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8592         endif
8593       endif
8594 C Cartesian derivatives.
8595       do iii=1,2
8596         do kkk=1,5
8597           do lll=1,3
8598 #ifdef MOMENT
8599             if (iii.eq.1) then
8600               if (imat.eq.1) then
8601                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8602               else
8603                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8604               endif
8605             else
8606               if (imat.eq.1) then
8607                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8608               else
8609                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8610               endif
8611             endif
8612 #endif
8613             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8614      &        auxvec(1))
8615             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8616             if (j.eq.l+1) then
8617               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8618      &          b1(1,itj1),auxvec(1))
8619               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8620             else
8621               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8622      &          b1(1,itl1),auxvec(1))
8623               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8624             endif
8625             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8626      &        pizda(1,1))
8627             vv(1)=pizda(1,1)-pizda(2,2)
8628             vv(2)=pizda(2,1)+pizda(1,2)
8629             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8630             if (swap) then
8631               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8632 #ifdef MOMENT
8633                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8634      &             -(s1+s2+s4)
8635 #else
8636                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8637      &             -(s2+s4)
8638 #endif
8639                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8640               else
8641 #ifdef MOMENT
8642                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8643 #else
8644                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8645 #endif
8646                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8647               endif
8648             else
8649 #ifdef MOMENT
8650               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8651 #else
8652               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8653 #endif
8654               if (l.eq.j+1) then
8655                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8656               else
8657                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8658               endif
8659             endif
8660           enddo
8661         enddo
8662       enddo
8663       return
8664       end
8665 c----------------------------------------------------------------------------
8666       double precision function eello_turn6(i,jj,kk)
8667       implicit real*8 (a-h,o-z)
8668       include 'DIMENSIONS'
8669       include 'COMMON.IOUNITS'
8670       include 'COMMON.CHAIN'
8671       include 'COMMON.DERIV'
8672       include 'COMMON.INTERACT'
8673       include 'COMMON.CONTACTS'
8674       include 'COMMON.TORSION'
8675       include 'COMMON.VAR'
8676       include 'COMMON.GEO'
8677       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8678      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8679      &  ggg1(3),ggg2(3)
8680       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8681      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8682 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8683 C           the respective energy moment and not to the cluster cumulant.
8684       s1=0.0d0
8685       s8=0.0d0
8686       s13=0.0d0
8687 c
8688       eello_turn6=0.0d0
8689       j=i+4
8690       k=i+1
8691       l=i+3
8692       iti=itortyp(itype(i))
8693       itk=itortyp(itype(k))
8694       itk1=itortyp(itype(k+1))
8695       itl=itortyp(itype(l))
8696       itj=itortyp(itype(j))
8697 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8698 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8699 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8700 cd        eello6=0.0d0
8701 cd        return
8702 cd      endif
8703 cd      write (iout,*)
8704 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8705 cd     &   ' and',k,l
8706 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8707       do iii=1,2
8708         do kkk=1,5
8709           do lll=1,3
8710             derx_turn(lll,kkk,iii)=0.0d0
8711           enddo
8712         enddo
8713       enddo
8714 cd      eij=1.0d0
8715 cd      ekl=1.0d0
8716 cd      ekont=1.0d0
8717       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8718 cd      eello6_5=0.0d0
8719 cd      write (2,*) 'eello6_5',eello6_5
8720 #ifdef MOMENT
8721       call transpose2(AEA(1,1,1),auxmat(1,1))
8722       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8723       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8724       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8725 #endif
8726       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8727       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8728       s2 = scalar2(b1(1,itk),vtemp1(1))
8729 #ifdef MOMENT
8730       call transpose2(AEA(1,1,2),atemp(1,1))
8731       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8732       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8733       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8734 #endif
8735       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8736       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8737       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8738 #ifdef MOMENT
8739       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8740       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8741       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8742       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8743       ss13 = scalar2(b1(1,itk),vtemp4(1))
8744       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8745 #endif
8746 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8747 c      s1=0.0d0
8748 c      s2=0.0d0
8749 c      s8=0.0d0
8750 c      s12=0.0d0
8751 c      s13=0.0d0
8752       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8753 C Derivatives in gamma(i+2)
8754       s1d =0.0d0
8755       s8d =0.0d0
8756 #ifdef MOMENT
8757       call transpose2(AEA(1,1,1),auxmatd(1,1))
8758       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8759       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8760       call transpose2(AEAderg(1,1,2),atempd(1,1))
8761       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8762       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8763 #endif
8764       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8765       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8766       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8767 c      s1d=0.0d0
8768 c      s2d=0.0d0
8769 c      s8d=0.0d0
8770 c      s12d=0.0d0
8771 c      s13d=0.0d0
8772       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8773 C Derivatives in gamma(i+3)
8774 #ifdef MOMENT
8775       call transpose2(AEA(1,1,1),auxmatd(1,1))
8776       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8777       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8778       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8779 #endif
8780       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8781       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8782       s2d = scalar2(b1(1,itk),vtemp1d(1))
8783 #ifdef MOMENT
8784       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8785       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8786 #endif
8787       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8788 #ifdef MOMENT
8789       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8790       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8791       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8792 #endif
8793 c      s1d=0.0d0
8794 c      s2d=0.0d0
8795 c      s8d=0.0d0
8796 c      s12d=0.0d0
8797 c      s13d=0.0d0
8798 #ifdef MOMENT
8799       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8800      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8801 #else
8802       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8803      &               -0.5d0*ekont*(s2d+s12d)
8804 #endif
8805 C Derivatives in gamma(i+4)
8806       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8807       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8808       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8809 #ifdef MOMENT
8810       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8811       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8812       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8813 #endif
8814 c      s1d=0.0d0
8815 c      s2d=0.0d0
8816 c      s8d=0.0d0
8817 C      s12d=0.0d0
8818 c      s13d=0.0d0
8819 #ifdef MOMENT
8820       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8821 #else
8822       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8823 #endif
8824 C Derivatives in gamma(i+5)
8825 #ifdef MOMENT
8826       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8827       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8828       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8829 #endif
8830       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8831       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8832       s2d = scalar2(b1(1,itk),vtemp1d(1))
8833 #ifdef MOMENT
8834       call transpose2(AEA(1,1,2),atempd(1,1))
8835       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8836       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8837 #endif
8838       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8839       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8840 #ifdef MOMENT
8841       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8842       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8843       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8844 #endif
8845 c      s1d=0.0d0
8846 c      s2d=0.0d0
8847 c      s8d=0.0d0
8848 c      s12d=0.0d0
8849 c      s13d=0.0d0
8850 #ifdef MOMENT
8851       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8852      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8853 #else
8854       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8855      &               -0.5d0*ekont*(s2d+s12d)
8856 #endif
8857 C Cartesian derivatives
8858       do iii=1,2
8859         do kkk=1,5
8860           do lll=1,3
8861 #ifdef MOMENT
8862             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8863             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8864             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8865 #endif
8866             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8867             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8868      &          vtemp1d(1))
8869             s2d = scalar2(b1(1,itk),vtemp1d(1))
8870 #ifdef MOMENT
8871             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8872             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8873             s8d = -(atempd(1,1)+atempd(2,2))*
8874      &           scalar2(cc(1,1,itl),vtemp2(1))
8875 #endif
8876             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8877      &           auxmatd(1,1))
8878             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8879             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8880 c      s1d=0.0d0
8881 c      s2d=0.0d0
8882 c      s8d=0.0d0
8883 c      s12d=0.0d0
8884 c      s13d=0.0d0
8885 #ifdef MOMENT
8886             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8887      &        - 0.5d0*(s1d+s2d)
8888 #else
8889             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8890      &        - 0.5d0*s2d
8891 #endif
8892 #ifdef MOMENT
8893             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8894      &        - 0.5d0*(s8d+s12d)
8895 #else
8896             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8897      &        - 0.5d0*s12d
8898 #endif
8899           enddo
8900         enddo
8901       enddo
8902 #ifdef MOMENT
8903       do kkk=1,5
8904         do lll=1,3
8905           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8906      &      achuj_tempd(1,1))
8907           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8908           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8909           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8910           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8911           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8912      &      vtemp4d(1))
8913           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8914           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8915           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8916         enddo
8917       enddo
8918 #endif
8919 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8920 cd     &  16*eel_turn6_num
8921 cd      goto 1112
8922       if (j.lt.nres-1) then
8923         j1=j+1
8924         j2=j-1
8925       else
8926         j1=j-1
8927         j2=j-2
8928       endif
8929       if (l.lt.nres-1) then
8930         l1=l+1
8931         l2=l-1
8932       else
8933         l1=l-1
8934         l2=l-2
8935       endif
8936       do ll=1,3
8937 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8938 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8939 cgrad        ghalf=0.5d0*ggg1(ll)
8940 cd        ghalf=0.0d0
8941         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8942         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8943         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8944      &    +ekont*derx_turn(ll,2,1)
8945         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8946         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8947      &    +ekont*derx_turn(ll,4,1)
8948         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8949         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8950         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8951 cgrad        ghalf=0.5d0*ggg2(ll)
8952 cd        ghalf=0.0d0
8953         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8954      &    +ekont*derx_turn(ll,2,2)
8955         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8956         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8957      &    +ekont*derx_turn(ll,4,2)
8958         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8959         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8960         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8961       enddo
8962 cd      goto 1112
8963 cgrad      do m=i+1,j-1
8964 cgrad        do ll=1,3
8965 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8966 cgrad        enddo
8967 cgrad      enddo
8968 cgrad      do m=k+1,l-1
8969 cgrad        do ll=1,3
8970 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8971 cgrad        enddo
8972 cgrad      enddo
8973 cgrad1112  continue
8974 cgrad      do m=i+2,j2
8975 cgrad        do ll=1,3
8976 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8977 cgrad        enddo
8978 cgrad      enddo
8979 cgrad      do m=k+2,l2
8980 cgrad        do ll=1,3
8981 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8982 cgrad        enddo
8983 cgrad      enddo
8984 cd      do iii=1,nres-3
8985 cd        write (2,*) iii,g_corr6_loc(iii)
8986 cd      enddo
8987       eello_turn6=ekont*eel_turn6
8988 cd      write (2,*) 'ekont',ekont
8989 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8990       return
8991       end
8992
8993 C-----------------------------------------------------------------------------
8994       double precision function scalar(u,v)
8995 !DIR$ INLINEALWAYS scalar
8996 #ifndef OSF
8997 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8998 #endif
8999       implicit none
9000       double precision u(3),v(3)
9001 cd      double precision sc
9002 cd      integer i
9003 cd      sc=0.0d0
9004 cd      do i=1,3
9005 cd        sc=sc+u(i)*v(i)
9006 cd      enddo
9007 cd      scalar=sc
9008
9009       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9010       return
9011       end
9012 crc-------------------------------------------------
9013       SUBROUTINE MATVEC2(A1,V1,V2)
9014 !DIR$ INLINEALWAYS MATVEC2
9015 #ifndef OSF
9016 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9017 #endif
9018       implicit real*8 (a-h,o-z)
9019       include 'DIMENSIONS'
9020       DIMENSION A1(2,2),V1(2),V2(2)
9021 c      DO 1 I=1,2
9022 c        VI=0.0
9023 c        DO 3 K=1,2
9024 c    3     VI=VI+A1(I,K)*V1(K)
9025 c        Vaux(I)=VI
9026 c    1 CONTINUE
9027
9028       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9029       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9030
9031       v2(1)=vaux1
9032       v2(2)=vaux2
9033       END
9034 C---------------------------------------
9035       SUBROUTINE MATMAT2(A1,A2,A3)
9036 #ifndef OSF
9037 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9038 #endif
9039       implicit real*8 (a-h,o-z)
9040       include 'DIMENSIONS'
9041       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9042 c      DIMENSION AI3(2,2)
9043 c        DO  J=1,2
9044 c          A3IJ=0.0
9045 c          DO K=1,2
9046 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9047 c          enddo
9048 c          A3(I,J)=A3IJ
9049 c       enddo
9050 c      enddo
9051
9052       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9053       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9054       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9055       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9056
9057       A3(1,1)=AI3_11
9058       A3(2,1)=AI3_21
9059       A3(1,2)=AI3_12
9060       A3(2,2)=AI3_22
9061       END
9062
9063 c-------------------------------------------------------------------------
9064       double precision function scalar2(u,v)
9065 !DIR$ INLINEALWAYS scalar2
9066       implicit none
9067       double precision u(2),v(2)
9068       double precision sc
9069       integer i
9070       scalar2=u(1)*v(1)+u(2)*v(2)
9071       return
9072       end
9073
9074 C-----------------------------------------------------------------------------
9075
9076       subroutine transpose2(a,at)
9077 !DIR$ INLINEALWAYS transpose2
9078 #ifndef OSF
9079 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9080 #endif
9081       implicit none
9082       double precision a(2,2),at(2,2)
9083       at(1,1)=a(1,1)
9084       at(1,2)=a(2,1)
9085       at(2,1)=a(1,2)
9086       at(2,2)=a(2,2)
9087       return
9088       end
9089 c--------------------------------------------------------------------------
9090       subroutine transpose(n,a,at)
9091       implicit none
9092       integer n,i,j
9093       double precision a(n,n),at(n,n)
9094       do i=1,n
9095         do j=1,n
9096           at(j,i)=a(i,j)
9097         enddo
9098       enddo
9099       return
9100       end
9101 C---------------------------------------------------------------------------
9102       subroutine prodmat3(a1,a2,kk,transp,prod)
9103 !DIR$ INLINEALWAYS prodmat3
9104 #ifndef OSF
9105 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9106 #endif
9107       implicit none
9108       integer i,j
9109       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9110       logical transp
9111 crc      double precision auxmat(2,2),prod_(2,2)
9112
9113       if (transp) then
9114 crc        call transpose2(kk(1,1),auxmat(1,1))
9115 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9116 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9117
9118            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9119      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9120            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9121      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9122            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9123      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9124            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9125      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9126
9127       else
9128 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9129 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9130
9131            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9132      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9133            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9134      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9135            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9136      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9137            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9138      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9139
9140       endif
9141 c      call transpose2(a2(1,1),a2t(1,1))
9142
9143 crc      print *,transp
9144 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9145 crc      print *,((prod(i,j),i=1,2),j=1,2)
9146
9147       return
9148       end
9149