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       include 'COMMON.SCCOR'
 487 #ifdef TIMING
 488 #ifdef MPI
 489       time01=MPI_Wtime()
 490 #else
 491       time01=tcpu()
 492 #endif
 493 #endif
 494 #ifdef DEBUG
 495       write (iout,*) "sum_gradient gvdwc, gvdwx"
 496       do i=1,nres
 497         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 498      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 499      &   (gvdwcT(j,i),j=1,3)
 500       enddo
 501       call flush(iout)
 502 #endif
 503 #ifdef MPI
 504 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 505         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 506      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 507 #endif
 508 C
 509 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 510 C            in virtual-bond-vector coordinates
 511 C
 512 #ifdef DEBUG
 513 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 514 c      do i=1,nres-1
 515 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 516 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 517 c      enddo
 518 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 519 c      do i=1,nres-1
 520 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 521 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 522 c      enddo
 523       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 524       do i=1,nres
 525         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 526      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 527      &   g_corr5_loc(i)
 528       enddo
 529       call flush(iout)
 530 #endif
 531 #ifdef SPLITELE
 532 #ifdef TSCSC
 533       do i=1,nct
 534         do j=1,3
 535           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 536      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 537      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 538      &                wel_loc*gel_loc_long(j,i)+
 539      &                wcorr*gradcorr_long(j,i)+
 540      &                wcorr5*gradcorr5_long(j,i)+
 541      &                wcorr6*gradcorr6_long(j,i)+
 542      &                wturn6*gcorr6_turn_long(j,i)+
 543      &                wstrain*ghpbc(j,i)
 544         enddo
 545       enddo
 546 #else
 547       do i=1,nct
 548         do j=1,3
 549           gradbufc(j,i)=wsc*gvdwc(j,i)+
 550      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 551      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 552      &                wel_loc*gel_loc_long(j,i)+
 553      &                wcorr*gradcorr_long(j,i)+
 554      &                wcorr5*gradcorr5_long(j,i)+
 555      &                wcorr6*gradcorr6_long(j,i)+
 556      &                wturn6*gcorr6_turn_long(j,i)+
 557      &                wstrain*ghpbc(j,i)
 558         enddo
 559       enddo
 560 #endif
 561 #else
 562       do i=1,nct
 563         do j=1,3
 564           gradbufc(j,i)=wsc*gvdwc(j,i)+
 565      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 566      &                welec*gelc_long(j,i)+
 567      &                wbond*gradb(j,i)+
 568      &                wel_loc*gel_loc_long(j,i)+
 569      &                wcorr*gradcorr_long(j,i)+
 570      &                wcorr5*gradcorr5_long(j,i)+
 571      &                wcorr6*gradcorr6_long(j,i)+
 572      &                wturn6*gcorr6_turn_long(j,i)+
 573      &                wstrain*ghpbc(j,i)
 574         enddo
 575       enddo
 576 #endif
 577 #ifdef MPI
 578       if (nfgtasks.gt.1) then
 579       time00=MPI_Wtime()
 580 #ifdef DEBUG
 581       write (iout,*) "gradbufc before allreduce"
 582       do i=1,nres
 583         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 584       enddo
 585       call flush(iout)
 586 #endif
 587       do i=1,nres
 588         do j=1,3
 589           gradbufc_sum(j,i)=gradbufc(j,i)
 590         enddo
 591       enddo
 592 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 593 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 594 c      time_reduce=time_reduce+MPI_Wtime()-time00
 595 #ifdef DEBUG
 596 c      write (iout,*) "gradbufc_sum after allreduce"
 597 c      do i=1,nres
 598 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 599 c      enddo
 600 c      call flush(iout)
 601 #endif
 602 #ifdef TIMING
 603 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 604 #endif
 605       do i=nnt,nres
 606         do k=1,3
 607           gradbufc(k,i)=0.0d0
 608         enddo
 609       enddo
 610 #ifdef DEBUG
 611       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 612       write (iout,*) (i," jgrad_start",jgrad_start(i),
 613      &                  " jgrad_end  ",jgrad_end(i),
 614      &                  i=igrad_start,igrad_end)
 615 #endif
 616 c
 617 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 618 c do not parallelize this part.
 619 c
 620 c      do i=igrad_start,igrad_end
 621 c        do j=jgrad_start(i),jgrad_end(i)
 622 c          do k=1,3
 623 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 624 c          enddo
 625 c        enddo
 626 c      enddo
 627       do j=1,3
 628         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 629       enddo
 630       do i=nres-2,nnt,-1
 631         do j=1,3
 632           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 633         enddo
 634       enddo
 635 #ifdef DEBUG
 636       write (iout,*) "gradbufc after summing"
 637       do i=1,nres
 638         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 639       enddo
 640       call flush(iout)
 641 #endif
 642       else
 643 #endif
 644 #ifdef DEBUG
 645       write (iout,*) "gradbufc"
 646       do i=1,nres
 647         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 648       enddo
 649       call flush(iout)
 650 #endif
 651       do i=1,nres
 652         do j=1,3
 653           gradbufc_sum(j,i)=gradbufc(j,i)
 654           gradbufc(j,i)=0.0d0
 655         enddo
 656       enddo
 657       do j=1,3
 658         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 659       enddo
 660       do i=nres-2,nnt,-1
 661         do j=1,3
 662           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 663         enddo
 664       enddo
 665 c      do i=nnt,nres-1
 666 c        do k=1,3
 667 c          gradbufc(k,i)=0.0d0
 668 c        enddo
 669 c        do j=i+1,nres
 670 c          do k=1,3
 671 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 672 c          enddo
 673 c        enddo
 674 c      enddo
 675 #ifdef DEBUG
 676       write (iout,*) "gradbufc after summing"
 677       do i=1,nres
 678         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 679       enddo
 680       call flush(iout)
 681 #endif
 682 #ifdef MPI
 683       endif
 684 #endif
 685       do k=1,3
 686         gradbufc(k,nres)=0.0d0
 687       enddo
 688       do i=1,nct
 689         do j=1,3
 690 #ifdef SPLITELE
 691           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 692      &                wel_loc*gel_loc(j,i)+
 693      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 694      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 695      &                wel_loc*gel_loc_long(j,i)+
 696      &                wcorr*gradcorr_long(j,i)+
 697      &                wcorr5*gradcorr5_long(j,i)+
 698      &                wcorr6*gradcorr6_long(j,i)+
 699      &                wturn6*gcorr6_turn_long(j,i))+
 700      &                wbond*gradb(j,i)+
 701      &                wcorr*gradcorr(j,i)+
 702      &                wturn3*gcorr3_turn(j,i)+
 703      &                wturn4*gcorr4_turn(j,i)+
 704      &                wcorr5*gradcorr5(j,i)+
 705      &                wcorr6*gradcorr6(j,i)+
 706      &                wturn6*gcorr6_turn(j,i)+
 707      &                wsccor*gsccorc(j,i)
 708      &               +wscloc*gscloc(j,i)
 709 #else
 710           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 711      &                wel_loc*gel_loc(j,i)+
 712      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 713      &                welec*gelc_long(j,i)+
 714      &                wel_loc*gel_loc_long(j,i)+
 715      &                wcorr*gcorr_long(j,i)+
 716      &                wcorr5*gradcorr5_long(j,i)+
 717      &                wcorr6*gradcorr6_long(j,i)+
 718      &                wturn6*gcorr6_turn_long(j,i))+
 719      &                wbond*gradb(j,i)+
 720      &                wcorr*gradcorr(j,i)+
 721      &                wturn3*gcorr3_turn(j,i)+
 722      &                wturn4*gcorr4_turn(j,i)+
 723      &                wcorr5*gradcorr5(j,i)+
 724      &                wcorr6*gradcorr6(j,i)+
 725      &                wturn6*gcorr6_turn(j,i)+
 726      &                wsccor*gsccorc(j,i)
 727      &               +wscloc*gscloc(j,i)
 728 #endif
 729 #ifdef TSCSC
 730           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 731      &                  wscp*gradx_scp(j,i)+
 732      &                  wbond*gradbx(j,i)+
 733      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 734      &                  wsccor*gsccorx(j,i)
 735      &                 +wscloc*gsclocx(j,i)
 736 #else
 737           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 738      &                  wbond*gradbx(j,i)+
 739      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 740      &                  wsccor*gsccorx(j,i)
 741      &                 +wscloc*gsclocx(j,i)
 742 #endif
 743         enddo
 744       enddo
 745 #ifdef DEBUG
 746       write (iout,*) "gloc before adding corr"
 747       do i=1,4*nres
 748         write (iout,*) i,gloc(i,icg)
 749       enddo
 750 #endif
 751       do i=1,nres-3
 752         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 753      &   +wcorr5*g_corr5_loc(i)
 754      &   +wcorr6*g_corr6_loc(i)
 755      &   +wturn4*gel_loc_turn4(i)
 756      &   +wturn3*gel_loc_turn3(i)
 757      &   +wturn6*gel_loc_turn6(i)
 758      &   +wel_loc*gel_loc_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 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4243 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4244 C    distance and angle dependent SS bond potential.
4245         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4246           call ssbond_ene(iii,jjj,eij)
4247           ehpb=ehpb+2*eij
4248 cd          write (iout,*) "eij",eij
4249         else
4250 C Calculate the distance between the two points and its difference from the
4251 C target distance.
4252         dd=dist(ii,jj)
4253         rdis=dd-dhpb(i)
4254 C Get the force constant corresponding to this distance.
4255         waga=forcon(i)
4256 C Calculate the contribution to energy.
4257         ehpb=ehpb+waga*rdis*rdis
4258 C
4259 C Evaluate gradient.
4260 C
4261         fac=waga*rdis/dd
4262 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4263 cd   &   ' waga=',waga,' fac=',fac
4264         do j=1,3
4265           ggg(j)=fac*(c(j,jj)-c(j,ii))
4266         enddo
4267 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4268 C If this is a SC-SC distance, we need to calculate the contributions to the
4269 C Cartesian gradient in the SC vectors (ghpbx).
4270         if (iii.lt.ii) then
4271           do j=1,3
4272             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4273             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4274           enddo
4275         endif
4276 cgrad        do j=iii,jjj-1
4277 cgrad          do k=1,3
4278 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4279 cgrad          enddo
4280 cgrad        enddo
4281         do k=1,3
4282           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4283           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4284         enddo
4285         endif
4286       enddo
4287       ehpb=0.5D0*ehpb
4288       return
4289       end
4290 C--------------------------------------------------------------------------
4291       subroutine ssbond_ene(i,j,eij)
4292 C
4293 C Calculate the distance and angle dependent SS-bond potential energy
4294 C using a free-energy function derived based on RHF/6-31G** ab initio
4295 C calculations of diethyl disulfide.
4296 C
4297 C A. Liwo and U. Kozlowska, 11/24/03
4298 C
4299       implicit real*8 (a-h,o-z)
4300       include 'DIMENSIONS'
4301       include 'COMMON.SBRIDGE'
4302       include 'COMMON.CHAIN'
4303       include 'COMMON.DERIV'
4304       include 'COMMON.LOCAL'
4305       include 'COMMON.INTERACT'
4306       include 'COMMON.VAR'
4307       include 'COMMON.IOUNITS'
4308       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4309       itypi=itype(i)
4310       xi=c(1,nres+i)
4311       yi=c(2,nres+i)
4312       zi=c(3,nres+i)
4313       dxi=dc_norm(1,nres+i)
4314       dyi=dc_norm(2,nres+i)
4315       dzi=dc_norm(3,nres+i)
4316 c      dsci_inv=dsc_inv(itypi)
4317       dsci_inv=vbld_inv(nres+i)
4318       itypj=itype(j)
4319 c      dscj_inv=dsc_inv(itypj)
4320       dscj_inv=vbld_inv(nres+j)
4321       xj=c(1,nres+j)-xi
4322       yj=c(2,nres+j)-yi
4323       zj=c(3,nres+j)-zi
4324       dxj=dc_norm(1,nres+j)
4325       dyj=dc_norm(2,nres+j)
4326       dzj=dc_norm(3,nres+j)
4327       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4328       rij=dsqrt(rrij)
4329       erij(1)=xj*rij
4330       erij(2)=yj*rij
4331       erij(3)=zj*rij
4332       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4333       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4334       om12=dxi*dxj+dyi*dyj+dzi*dzj
4335       do k=1,3
4336         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4337         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4338       enddo
4339       rij=1.0d0/rij
4340       deltad=rij-d0cm
4341       deltat1=1.0d0-om1
4342       deltat2=1.0d0+om2
4343       deltat12=om2-om1+2.0d0
4344       cosphi=om12-om1*om2
4345       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4346      &  +akct*deltad*deltat12
4347      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4348 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4349 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4350 c     &  " deltat12",deltat12," eij",eij
4351       ed=2*akcm*deltad+akct*deltat12
4352       pom1=akct*deltad
4353       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4354       eom1=-2*akth*deltat1-pom1-om2*pom2
4355       eom2= 2*akth*deltat2+pom1-om1*pom2
4356       eom12=pom2
4357       do k=1,3
4358         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4359         ghpbx(k,i)=ghpbx(k,i)-ggk
4360      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4361      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4362         ghpbx(k,j)=ghpbx(k,j)+ggk
4363      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4364      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4365         ghpbc(k,i)=ghpbc(k,i)-ggk
4366         ghpbc(k,j)=ghpbc(k,j)+ggk
4367       enddo
4368 C
4369 C Calculate the components of the gradient in DC and X
4370 C
4371 cgrad      do k=i,j-1
4372 cgrad        do l=1,3
4373 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4374 cgrad        enddo
4375 cgrad      enddo
4376       return
4377       end
4378 C--------------------------------------------------------------------------
4379       subroutine ebond(estr)
4380 c
4381 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4382 c
4383       implicit real*8 (a-h,o-z)
4384       include 'DIMENSIONS'
4385       include 'COMMON.LOCAL'
4386       include 'COMMON.GEO'
4387       include 'COMMON.INTERACT'
4388       include 'COMMON.DERIV'
4389       include 'COMMON.VAR'
4390       include 'COMMON.CHAIN'
4391       include 'COMMON.IOUNITS'
4392       include 'COMMON.NAMES'
4393       include 'COMMON.FFIELD'
4394       include 'COMMON.CONTROL'
4395       include 'COMMON.SETUP'
4396       double precision u(3),ud(3)
4397       estr=0.0d0
4398       do i=ibondp_start,ibondp_end
4399         diff = vbld(i)-vbldp0
4400 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4401         estr=estr+diff*diff
4402         do j=1,3
4403           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4404         enddo
4405 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4406       enddo
4407       estr=0.5d0*AKP*estr
4408 c
4409 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4410 c
4411       do i=ibond_start,ibond_end
4412         iti=itype(i)
4413         if (iti.ne.10) then
4414           nbi=nbondterm(iti)
4415           if (nbi.eq.1) then
4416             diff=vbld(i+nres)-vbldsc0(1,iti)
4417 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4418 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4419             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4420             do j=1,3
4421               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4422             enddo
4423           else
4424             do j=1,nbi
4425               diff=vbld(i+nres)-vbldsc0(j,iti)
4426               ud(j)=aksc(j,iti)*diff
4427               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4428             enddo
4429             uprod=u(1)
4430             do j=2,nbi
4431               uprod=uprod*u(j)
4432             enddo
4433             usum=0.0d0
4434             usumsqder=0.0d0
4435             do j=1,nbi
4436               uprod1=1.0d0
4437               uprod2=1.0d0
4438               do k=1,nbi
4439                 if (k.ne.j) then
4440                   uprod1=uprod1*u(k)
4441                   uprod2=uprod2*u(k)*u(k)
4442                 endif
4443               enddo
4444               usum=usum+uprod1
4445               usumsqder=usumsqder+ud(j)*uprod2
4446             enddo
4447             estr=estr+uprod/usum
4448             do j=1,3
4449              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4450             enddo
4451           endif
4452         endif
4453       enddo
4454       return
4455       end
4456 #ifdef CRYST_THETA
4457 C--------------------------------------------------------------------------
4458       subroutine ebend(etheta)
4459 C
4460 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4461 C angles gamma and its derivatives in consecutive thetas and gammas.
4462 C
4463       implicit real*8 (a-h,o-z)
4464       include 'DIMENSIONS'
4465       include 'COMMON.LOCAL'
4466       include 'COMMON.GEO'
4467       include 'COMMON.INTERACT'
4468       include 'COMMON.DERIV'
4469       include 'COMMON.VAR'
4470       include 'COMMON.CHAIN'
4471       include 'COMMON.IOUNITS'
4472       include 'COMMON.NAMES'
4473       include 'COMMON.FFIELD'
4474       include 'COMMON.CONTROL'
4475       common /calcthet/ term1,term2,termm,diffak,ratak,
4476      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4477      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4478       double precision y(2),z(2)
4479       delta=0.02d0*pi
4480 c      time11=dexp(-2*time)
4481 c      time12=1.0d0
4482       etheta=0.0D0
4483 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4484       do i=ithet_start,ithet_end
4485 C Zero the energy function and its derivative at 0 or pi.
4486         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4487         it=itype(i-1)
4488         if (i.gt.3) then
4489 #ifdef OSF
4490           phii=phi(i)
4491           if (phii.ne.phii) phii=150.0
4492 #else
4493           phii=phi(i)
4494 #endif
4495           y(1)=dcos(phii)
4496           y(2)=dsin(phii)
4497         else
4498           y(1)=0.0D0
4499           y(2)=0.0D0
4500         endif
4501         if (i.lt.nres) then
4502 #ifdef OSF
4503           phii1=phi(i+1)
4504           if (phii1.ne.phii1) phii1=150.0
4505           phii1=pinorm(phii1)
4506           z(1)=cos(phii1)
4507 #else
4508           phii1=phi(i+1)
4509           z(1)=dcos(phii1)
4510 #endif
4511           z(2)=dsin(phii1)
4512         else
4513           z(1)=0.0D0
4514           z(2)=0.0D0
4515         endif
4516 C Calculate the "mean" value of theta from the part of the distribution
4517 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4518 C In following comments this theta will be referred to as t_c.
4519         thet_pred_mean=0.0d0
4520         do k=1,2
4521           athetk=athet(k,it)
4522           bthetk=bthet(k,it)
4523           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4524         enddo
4525         dthett=thet_pred_mean*ssd
4526         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4527 C Derivatives of the "mean" values in gamma1 and gamma2.
4528         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4529         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4530         if (theta(i).gt.pi-delta) then
4531           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4532      &         E_tc0)
4533           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4534           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4535           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4536      &        E_theta)
4537           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4538      &        E_tc)
4539         else if (theta(i).lt.delta) then
4540           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4541           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4542           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4543      &        E_theta)
4544           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4545           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4546      &        E_tc)
4547         else
4548           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4549      &        E_theta,E_tc)
4550         endif
4551         etheta=etheta+ethetai
4552         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4553      &      'ebend',i,ethetai
4554         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4555         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4556         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4557       enddo
4558 C Ufff.... We've done all this!!!
4559       return
4560       end
4561 C---------------------------------------------------------------------------
4562       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4563      &     E_tc)
4564       implicit real*8 (a-h,o-z)
4565       include 'DIMENSIONS'
4566       include 'COMMON.LOCAL'
4567       include 'COMMON.IOUNITS'
4568       common /calcthet/ term1,term2,termm,diffak,ratak,
4569      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4570      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4571 C Calculate the contributions to both Gaussian lobes.
4572 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4573 C The "polynomial part" of the "standard deviation" of this part of
4574 C the distribution.
4575         sig=polthet(3,it)
4576         do j=2,0,-1
4577           sig=sig*thet_pred_mean+polthet(j,it)
4578         enddo
4579 C Derivative of the "interior part" of the "standard deviation of the"
4580 C gamma-dependent Gaussian lobe in t_c.
4581         sigtc=3*polthet(3,it)
4582         do j=2,1,-1
4583           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4584         enddo
4585         sigtc=sig*sigtc
4586 C Set the parameters of both Gaussian lobes of the distribution.
4587 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4588         fac=sig*sig+sigc0(it)
4589         sigcsq=fac+fac
4590         sigc=1.0D0/sigcsq
4591 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4592         sigsqtc=-4.0D0*sigcsq*sigtc
4593 c       print *,i,sig,sigtc,sigsqtc
4594 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4595         sigtc=-sigtc/(fac*fac)
4596 C Following variable is sigma(t_c)**(-2)
4597         sigcsq=sigcsq*sigcsq
4598         sig0i=sig0(it)
4599         sig0inv=1.0D0/sig0i**2
4600         delthec=thetai-thet_pred_mean
4601         delthe0=thetai-theta0i
4602         term1=-0.5D0*sigcsq*delthec*delthec
4603         term2=-0.5D0*sig0inv*delthe0*delthe0
4604 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4605 C NaNs in taking the logarithm. We extract the largest exponent which is added
4606 C to the energy (this being the log of the distribution) at the end of energy
4607 C term evaluation for this virtual-bond angle.
4608         if (term1.gt.term2) then
4609           termm=term1
4610           term2=dexp(term2-termm)
4611           term1=1.0d0
4612         else
4613           termm=term2
4614           term1=dexp(term1-termm)
4615           term2=1.0d0
4616         endif
4617 C The ratio between the gamma-independent and gamma-dependent lobes of
4618 C the distribution is a Gaussian function of thet_pred_mean too.
4619         diffak=gthet(2,it)-thet_pred_mean
4620         ratak=diffak/gthet(3,it)**2
4621         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4622 C Let's differentiate it in thet_pred_mean NOW.
4623         aktc=ak*ratak
4624 C Now put together the distribution terms to make complete distribution.
4625         termexp=term1+ak*term2
4626         termpre=sigc+ak*sig0i
4627 C Contribution of the bending energy from this theta is just the -log of
4628 C the sum of the contributions from the two lobes and the pre-exponential
4629 C factor. Simple enough, isn't it?
4630         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4631 C NOW the derivatives!!!
4632 C 6/6/97 Take into account the deformation.
4633         E_theta=(delthec*sigcsq*term1
4634      &       +ak*delthe0*sig0inv*term2)/termexp
4635         E_tc=((sigtc+aktc*sig0i)/termpre
4636      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4637      &       aktc*term2)/termexp)
4638       return
4639       end
4640 c-----------------------------------------------------------------------------
4641       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4642       implicit real*8 (a-h,o-z)
4643       include 'DIMENSIONS'
4644       include 'COMMON.LOCAL'
4645       include 'COMMON.IOUNITS'
4646       common /calcthet/ term1,term2,termm,diffak,ratak,
4647      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4648      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4649       delthec=thetai-thet_pred_mean
4650       delthe0=thetai-theta0i
4651 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4652       t3 = thetai-thet_pred_mean
4653       t6 = t3**2
4654       t9 = term1
4655       t12 = t3*sigcsq
4656       t14 = t12+t6*sigsqtc
4657       t16 = 1.0d0
4658       t21 = thetai-theta0i
4659       t23 = t21**2
4660       t26 = term2
4661       t27 = t21*t26
4662       t32 = termexp
4663       t40 = t32**2
4664       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4665      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4666      & *(-t12*t9-ak*sig0inv*t27)
4667       return
4668       end
4669 #else
4670 C--------------------------------------------------------------------------
4671       subroutine ebend(etheta)
4672 C
4673 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4674 C angles gamma and its derivatives in consecutive thetas and gammas.
4675 C ab initio-derived potentials from
4676 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4677 C
4678       implicit real*8 (a-h,o-z)
4679       include 'DIMENSIONS'
4680       include 'COMMON.LOCAL'
4681       include 'COMMON.GEO'
4682       include 'COMMON.INTERACT'
4683       include 'COMMON.DERIV'
4684       include 'COMMON.VAR'
4685       include 'COMMON.CHAIN'
4686       include 'COMMON.IOUNITS'
4687       include 'COMMON.NAMES'
4688       include 'COMMON.FFIELD'
4689       include 'COMMON.CONTROL'
4690       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4691      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4692      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4693      & sinph1ph2(maxdouble,maxdouble)
4694       logical lprn /.false./, lprn1 /.false./
4695       etheta=0.0D0
4696       do i=ithet_start,ithet_end
4697         dethetai=0.0d0
4698         dephii=0.0d0
4699         dephii1=0.0d0
4700         theti2=0.5d0*theta(i)
4701         ityp2=ithetyp(itype(i-1))
4702         do k=1,nntheterm
4703           coskt(k)=dcos(k*theti2)
4704           sinkt(k)=dsin(k*theti2)
4705         enddo
4706         if (i.gt.3) then
4707 #ifdef OSF
4708           phii=phi(i)
4709           if (phii.ne.phii) phii=150.0
4710 #else
4711           phii=phi(i)
4712 #endif
4713           ityp1=ithetyp(itype(i-2))
4714           do k=1,nsingle
4715             cosph1(k)=dcos(k*phii)
4716             sinph1(k)=dsin(k*phii)
4717           enddo
4718         else
4719           phii=0.0d0
4720           ityp1=nthetyp+1
4721           do k=1,nsingle
4722             cosph1(k)=0.0d0
4723             sinph1(k)=0.0d0
4724           enddo
4725         endif
4726         if (i.lt.nres) then
4727 #ifdef OSF
4728           phii1=phi(i+1)
4729           if (phii1.ne.phii1) phii1=150.0
4730           phii1=pinorm(phii1)
4731 #else
4732           phii1=phi(i+1)
4733 #endif
4734           ityp3=ithetyp(itype(i))
4735           do k=1,nsingle
4736             cosph2(k)=dcos(k*phii1)
4737             sinph2(k)=dsin(k*phii1)
4738           enddo
4739         else
4740           phii1=0.0d0
4741           ityp3=nthetyp+1
4742           do k=1,nsingle
4743             cosph2(k)=0.0d0
4744             sinph2(k)=0.0d0
4745           enddo
4746         endif
4747         ethetai=aa0thet(ityp1,ityp2,ityp3)
4748         do k=1,ndouble
4749           do l=1,k-1
4750             ccl=cosph1(l)*cosph2(k-l)
4751             ssl=sinph1(l)*sinph2(k-l)
4752             scl=sinph1(l)*cosph2(k-l)
4753             csl=cosph1(l)*sinph2(k-l)
4754             cosph1ph2(l,k)=ccl-ssl
4755             cosph1ph2(k,l)=ccl+ssl
4756             sinph1ph2(l,k)=scl+csl
4757             sinph1ph2(k,l)=scl-csl
4758           enddo
4759         enddo
4760         if (lprn) then
4761         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4762      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4763         write (iout,*) "coskt and sinkt"
4764         do k=1,nntheterm
4765           write (iout,*) k,coskt(k),sinkt(k)
4766         enddo
4767         endif
4768         do k=1,ntheterm
4769           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4770           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4771      &      *coskt(k)
4772           if (lprn)
4773      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4774      &     " ethetai",ethetai
4775         enddo
4776         if (lprn) then
4777         write (iout,*) "cosph and sinph"
4778         do k=1,nsingle
4779           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4780         enddo
4781         write (iout,*) "cosph1ph2 and sinph2ph2"
4782         do k=2,ndouble
4783           do l=1,k-1
4784             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4785      &         sinph1ph2(l,k),sinph1ph2(k,l)
4786           enddo
4787         enddo
4788         write(iout,*) "ethetai",ethetai
4789         endif
4790         do m=1,ntheterm2
4791           do k=1,nsingle
4792             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4793      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4794      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4795      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4796             ethetai=ethetai+sinkt(m)*aux
4797             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4798             dephii=dephii+k*sinkt(m)*(
4799      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4800      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4801             dephii1=dephii1+k*sinkt(m)*(
4802      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4803      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4804             if (lprn)
4805      &      write (iout,*) "m",m," k",k," bbthet",
4806      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4807      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4808      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4809      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4810           enddo
4811         enddo
4812         if (lprn)
4813      &  write(iout,*) "ethetai",ethetai
4814         do m=1,ntheterm3
4815           do k=2,ndouble
4816             do l=1,k-1
4817               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4818      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4819      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4820      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4821               ethetai=ethetai+sinkt(m)*aux
4822               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4823               dephii=dephii+l*sinkt(m)*(
4824      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4825      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4826      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4827      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4828               dephii1=dephii1+(k-l)*sinkt(m)*(
4829      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4830      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4831      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4832      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4833               if (lprn) then
4834               write (iout,*) "m",m," k",k," l",l," ffthet",
4835      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4836      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4837      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4838      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4839               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4840      &            cosph1ph2(k,l)*sinkt(m),
4841      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4842               endif
4843             enddo
4844           enddo
4845         enddo
4846 10      continue
4847         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4848      &   i,theta(i)*rad2deg,phii*rad2deg,
4849      &   phii1*rad2deg,ethetai
4850         etheta=etheta+ethetai
4851         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4852         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4853         gloc(nphi+i-2,icg)=wang*dethetai
4854       enddo
4855       return
4856       end
4857 #endif
4858 #ifdef CRYST_SC
4859 c-----------------------------------------------------------------------------
4860       subroutine esc(escloc)
4861 C Calculate the local energy of a side chain and its derivatives in the
4862 C corresponding virtual-bond valence angles THETA and the spherical angles
4863 C ALPHA and OMEGA.
4864       implicit real*8 (a-h,o-z)
4865       include 'DIMENSIONS'
4866       include 'COMMON.GEO'
4867       include 'COMMON.LOCAL'
4868       include 'COMMON.VAR'
4869       include 'COMMON.INTERACT'
4870       include 'COMMON.DERIV'
4871       include 'COMMON.CHAIN'
4872       include 'COMMON.IOUNITS'
4873       include 'COMMON.NAMES'
4874       include 'COMMON.FFIELD'
4875       include 'COMMON.CONTROL'
4876       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4877      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4878       common /sccalc/ time11,time12,time112,theti,it,nlobit
4879       delta=0.02d0*pi
4880       escloc=0.0D0
4881 c     write (iout,'(a)') 'ESC'
4882       do i=loc_start,loc_end
4883         it=itype(i)
4884         if (it.eq.10) goto 1
4885         nlobit=nlob(it)
4886 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4887 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4888         theti=theta(i+1)-pipol
4889         x(1)=dtan(theti)
4890         x(2)=alph(i)
4891         x(3)=omeg(i)
4892
4893         if (x(2).gt.pi-delta) then
4894           xtemp(1)=x(1)
4895           xtemp(2)=pi-delta
4896           xtemp(3)=x(3)
4897           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4898           xtemp(2)=pi
4899           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4900           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4901      &        escloci,dersc(2))
4902           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4903      &        ddersc0(1),dersc(1))
4904           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4905      &        ddersc0(3),dersc(3))
4906           xtemp(2)=pi-delta
4907           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4908           xtemp(2)=pi
4909           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4910           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4911      &            dersc0(2),esclocbi,dersc02)
4912           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4913      &            dersc12,dersc01)
4914           call splinthet(x(2),0.5d0*delta,ss,ssd)
4915           dersc0(1)=dersc01
4916           dersc0(2)=dersc02
4917           dersc0(3)=0.0d0
4918           do k=1,3
4919             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4920           enddo
4921           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4922 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4923 c    &             esclocbi,ss,ssd
4924           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4925 c         escloci=esclocbi
4926 c         write (iout,*) escloci
4927         else if (x(2).lt.delta) then
4928           xtemp(1)=x(1)
4929           xtemp(2)=delta
4930           xtemp(3)=x(3)
4931           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4932           xtemp(2)=0.0d0
4933           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4934           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4935      &        escloci,dersc(2))
4936           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4937      &        ddersc0(1),dersc(1))
4938           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4939      &        ddersc0(3),dersc(3))
4940           xtemp(2)=delta
4941           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4942           xtemp(2)=0.0d0
4943           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4944           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4945      &            dersc0(2),esclocbi,dersc02)
4946           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4947      &            dersc12,dersc01)
4948           dersc0(1)=dersc01
4949           dersc0(2)=dersc02
4950           dersc0(3)=0.0d0
4951           call splinthet(x(2),0.5d0*delta,ss,ssd)
4952           do k=1,3
4953             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4954           enddo
4955           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4956 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4957 c    &             esclocbi,ss,ssd
4958           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4959 c         write (iout,*) escloci
4960         else
4961           call enesc(x,escloci,dersc,ddummy,.false.)
4962         endif
4963
4964         escloc=escloc+escloci
4965         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4966      &     'escloc',i,escloci
4967 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4968
4969         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4970      &   wscloc*dersc(1)
4971         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4972         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4973     1   continue
4974       enddo
4975       return
4976       end
4977 C---------------------------------------------------------------------------
4978       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4979       implicit real*8 (a-h,o-z)
4980       include 'DIMENSIONS'
4981       include 'COMMON.GEO'
4982       include 'COMMON.LOCAL'
4983       include 'COMMON.IOUNITS'
4984       common /sccalc/ time11,time12,time112,theti,it,nlobit
4985       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4986       double precision contr(maxlob,-1:1)
4987       logical mixed
4988 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4989         escloc_i=0.0D0
4990         do j=1,3
4991           dersc(j)=0.0D0
4992           if (mixed) ddersc(j)=0.0d0
4993         enddo
4994         x3=x(3)
4995
4996 C Because of periodicity of the dependence of the SC energy in omega we have
4997 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4998 C To avoid underflows, first compute & store the exponents.
4999
5000         do iii=-1,1
5001
5002           x(3)=x3+iii*dwapi
5003
5004           do j=1,nlobit
5005             do k=1,3
5006               z(k)=x(k)-censc(k,j,it)
5007             enddo
5008             do k=1,3
5009               Axk=0.0D0
5010               do l=1,3
5011                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5012               enddo
5013               Ax(k,j,iii)=Axk
5014             enddo
5015             expfac=0.0D0
5016             do k=1,3
5017               expfac=expfac+Ax(k,j,iii)*z(k)
5018             enddo
5019             contr(j,iii)=expfac
5020           enddo ! j
5021
5022         enddo ! iii
5023
5024         x(3)=x3
5025 C As in the case of ebend, we want to avoid underflows in exponentiation and
5026 C subsequent NaNs and INFs in energy calculation.
5027 C Find the largest exponent
5028         emin=contr(1,-1)
5029         do iii=-1,1
5030           do j=1,nlobit
5031             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5032           enddo
5033         enddo
5034         emin=0.5D0*emin
5035 cd      print *,'it=',it,' emin=',emin
5036
5037 C Compute the contribution to SC energy and derivatives
5038         do iii=-1,1
5039
5040           do j=1,nlobit
5041 #ifdef OSF
5042             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5043             if(adexp.ne.adexp) adexp=1.0
5044             expfac=dexp(adexp)
5045 #else
5046             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5047 #endif
5048 cd          print *,'j=',j,' expfac=',expfac
5049             escloc_i=escloc_i+expfac
5050             do k=1,3
5051               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5052             enddo
5053             if (mixed) then
5054               do k=1,3,2
5055                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5056      &            +gaussc(k,2,j,it))*expfac
5057               enddo
5058             endif
5059           enddo
5060
5061         enddo ! iii
5062
5063         dersc(1)=dersc(1)/cos(theti)**2
5064         ddersc(1)=ddersc(1)/cos(theti)**2
5065         ddersc(3)=ddersc(3)
5066
5067         escloci=-(dlog(escloc_i)-emin)
5068         do j=1,3
5069           dersc(j)=dersc(j)/escloc_i
5070         enddo
5071         if (mixed) then
5072           do j=1,3,2
5073             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5074           enddo
5075         endif
5076       return
5077       end
5078 C------------------------------------------------------------------------------
5079       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5080       implicit real*8 (a-h,o-z)
5081       include 'DIMENSIONS'
5082       include 'COMMON.GEO'
5083       include 'COMMON.LOCAL'
5084       include 'COMMON.IOUNITS'
5085       common /sccalc/ time11,time12,time112,theti,it,nlobit
5086       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5087       double precision contr(maxlob)
5088       logical mixed
5089
5090       escloc_i=0.0D0
5091
5092       do j=1,3
5093         dersc(j)=0.0D0
5094       enddo
5095
5096       do j=1,nlobit
5097         do k=1,2
5098           z(k)=x(k)-censc(k,j,it)
5099         enddo
5100         z(3)=dwapi
5101         do k=1,3
5102           Axk=0.0D0
5103           do l=1,3
5104             Axk=Axk+gaussc(l,k,j,it)*z(l)
5105           enddo
5106           Ax(k,j)=Axk
5107         enddo
5108         expfac=0.0D0
5109         do k=1,3
5110           expfac=expfac+Ax(k,j)*z(k)
5111         enddo
5112         contr(j)=expfac
5113       enddo ! j
5114
5115 C As in the case of ebend, we want to avoid underflows in exponentiation and
5116 C subsequent NaNs and INFs in energy calculation.
5117 C Find the largest exponent
5118       emin=contr(1)
5119       do j=1,nlobit
5120         if (emin.gt.contr(j)) emin=contr(j)
5121       enddo
5122       emin=0.5D0*emin
5123
5124 C Compute the contribution to SC energy and derivatives
5125
5126       dersc12=0.0d0
5127       do j=1,nlobit
5128         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5129         escloc_i=escloc_i+expfac
5130         do k=1,2
5131           dersc(k)=dersc(k)+Ax(k,j)*expfac
5132         enddo
5133         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5134      &            +gaussc(1,2,j,it))*expfac
5135         dersc(3)=0.0d0
5136       enddo
5137
5138       dersc(1)=dersc(1)/cos(theti)**2
5139       dersc12=dersc12/cos(theti)**2
5140       escloci=-(dlog(escloc_i)-emin)
5141       do j=1,2
5142         dersc(j)=dersc(j)/escloc_i
5143       enddo
5144       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5145       return
5146       end
5147 #else
5148 c----------------------------------------------------------------------------------
5149       subroutine esc(escloc)
5150 C Calculate the local energy of a side chain and its derivatives in the
5151 C corresponding virtual-bond valence angles THETA and the spherical angles
5152 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5153 C added by Urszula Kozlowska. 07/11/2007
5154 C
5155       implicit real*8 (a-h,o-z)
5156       include 'DIMENSIONS'
5157       include 'COMMON.GEO'
5158       include 'COMMON.LOCAL'
5159       include 'COMMON.VAR'
5160       include 'COMMON.SCROT'
5161       include 'COMMON.INTERACT'
5162       include 'COMMON.DERIV'
5163       include 'COMMON.CHAIN'
5164       include 'COMMON.IOUNITS'
5165       include 'COMMON.NAMES'
5166       include 'COMMON.FFIELD'
5167       include 'COMMON.CONTROL'
5168       include 'COMMON.VECTORS'
5169       double precision x_prime(3),y_prime(3),z_prime(3)
5170      &    , sumene,dsc_i,dp2_i,x(65),
5171      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5172      &    de_dxx,de_dyy,de_dzz,de_dt
5173       double precision s1_t,s1_6_t,s2_t,s2_6_t
5174       double precision
5175      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5176      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5177      & dt_dCi(3),dt_dCi1(3)
5178       common /sccalc/ time11,time12,time112,theti,it,nlobit
5179       delta=0.02d0*pi
5180       escloc=0.0D0
5181       do i=loc_start,loc_end
5182         costtab(i+1) =dcos(theta(i+1))
5183         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5184         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5185         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5186         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5187         cosfac=dsqrt(cosfac2)
5188         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5189         sinfac=dsqrt(sinfac2)
5190         it=itype(i)
5191         if (it.eq.10) goto 1
5192 c
5193 C  Compute the axes of tghe local cartesian coordinates system; store in
5194 c   x_prime, y_prime and z_prime
5195 c
5196         do j=1,3
5197           x_prime(j) = 0.00
5198           y_prime(j) = 0.00
5199           z_prime(j) = 0.00
5200         enddo
5201 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5202 C     &   dc_norm(3,i+nres)
5203         do j = 1,3
5204           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5205           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5206         enddo
5207         do j = 1,3
5208           z_prime(j) = -uz(j,i-1)
5209         enddo
5210 c       write (2,*) "i",i
5211 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5212 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5213 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5214 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5215 c      & " xy",scalar(x_prime(1),y_prime(1)),
5216 c      & " xz",scalar(x_prime(1),z_prime(1)),
5217 c      & " yy",scalar(y_prime(1),y_prime(1)),
5218 c      & " yz",scalar(y_prime(1),z_prime(1)),
5219 c      & " zz",scalar(z_prime(1),z_prime(1))
5220 c
5221 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5222 C to local coordinate system. Store in xx, yy, zz.
5223 c
5224         xx=0.0d0
5225         yy=0.0d0
5226         zz=0.0d0
5227         do j = 1,3
5228           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5229           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5230           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5231         enddo
5232
5233         xxtab(i)=xx
5234         yytab(i)=yy
5235         zztab(i)=zz
5236 C
5237 C Compute the energy of the ith side cbain
5238 C
5239 c        write (2,*) "xx",xx," yy",yy," zz",zz
5240         it=itype(i)
5241         do j = 1,65
5242           x(j) = sc_parmin(j,it)
5243         enddo
5244 #ifdef CHECK_COORD
5245 Cc diagnostics - remove later
5246         xx1 = dcos(alph(2))
5247         yy1 = dsin(alph(2))*dcos(omeg(2))
5248         zz1 = -dsin(alph(2))*dsin(omeg(2))
5249         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5250      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5251      &    xx1,yy1,zz1
5252 C,"  --- ", xx_w,yy_w,zz_w
5253 c end diagnostics
5254 #endif
5255         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5256      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5257      &   + x(10)*yy*zz
5258         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5259      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5260      & + x(20)*yy*zz
5261         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5262      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5263      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5264      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5265      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5266      &  +x(40)*xx*yy*zz
5267         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5268      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5269      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5270      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5271      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5272      &  +x(60)*xx*yy*zz
5273         dsc_i   = 0.743d0+x(61)
5274         dp2_i   = 1.9d0+x(62)
5275         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5276      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5277         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5278      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5279         s1=(1+x(63))/(0.1d0 + dscp1)
5280         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5281         s2=(1+x(65))/(0.1d0 + dscp2)
5282         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5283         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5284      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5285 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5286 c     &   sumene4,
5287 c     &   dscp1,dscp2,sumene
5288 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5289         escloc = escloc + sumene
5290 c        write (2,*) "i",i," escloc",sumene,escloc
5291 #ifdef DEBUG
5292 C
5293 C This section to check the numerical derivatives of the energy of ith side
5294 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5295 C #define DEBUG in the code to turn it on.
5296 C
5297         write (2,*) "sumene               =",sumene
5298         aincr=1.0d-7
5299         xxsave=xx
5300         xx=xx+aincr
5301         write (2,*) xx,yy,zz
5302         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5303         de_dxx_num=(sumenep-sumene)/aincr
5304         xx=xxsave
5305         write (2,*) "xx+ sumene from enesc=",sumenep
5306         yysave=yy
5307         yy=yy+aincr
5308         write (2,*) xx,yy,zz
5309         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5310         de_dyy_num=(sumenep-sumene)/aincr
5311         yy=yysave
5312         write (2,*) "yy+ sumene from enesc=",sumenep
5313         zzsave=zz
5314         zz=zz+aincr
5315         write (2,*) xx,yy,zz
5316         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5317         de_dzz_num=(sumenep-sumene)/aincr
5318         zz=zzsave
5319         write (2,*) "zz+ sumene from enesc=",sumenep
5320         costsave=cost2tab(i+1)
5321         sintsave=sint2tab(i+1)
5322         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5323         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5324         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5325         de_dt_num=(sumenep-sumene)/aincr
5326         write (2,*) " t+ sumene from enesc=",sumenep
5327         cost2tab(i+1)=costsave
5328         sint2tab(i+1)=sintsave
5329 C End of diagnostics section.
5330 #endif
5331 C
5332 C Compute the gradient of esc
5333 C
5334         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5335         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5336         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5337         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5338         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5339         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5340         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5341         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5342         pom1=(sumene3*sint2tab(i+1)+sumene1)
5343      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5344         pom2=(sumene4*cost2tab(i+1)+sumene2)
5345      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5346         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5347         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5348      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5349      &  +x(40)*yy*zz
5350         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5351         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5352      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5353      &  +x(60)*yy*zz
5354         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5355      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5356      &        +(pom1+pom2)*pom_dx
5357 #ifdef DEBUG
5358         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5359 #endif
5360 C
5361         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5362         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5363      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5364      &  +x(40)*xx*zz
5365         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5366         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5367      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5368      &  +x(59)*zz**2 +x(60)*xx*zz
5369         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5370      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5371      &        +(pom1-pom2)*pom_dy
5372 #ifdef DEBUG
5373         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5374 #endif
5375 C
5376         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5377      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5378      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5379      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5380      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5381      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5382      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5383      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5384 #ifdef DEBUG
5385         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5386 #endif
5387 C
5388         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5389      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5390      &  +pom1*pom_dt1+pom2*pom_dt2
5391 #ifdef DEBUG
5392         write(2,*), "de_dt = ", de_dt,de_dt_num
5393 #endif
5394 c
5395 C
5396        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5397        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5398        cosfac2xx=cosfac2*xx
5399        sinfac2yy=sinfac2*yy
5400        do k = 1,3
5401          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5402      &      vbld_inv(i+1)
5403          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5404      &      vbld_inv(i)
5405          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5406          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5407 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5408 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5409 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5410 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5411          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5412          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5413          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5414          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5415          dZZ_Ci1(k)=0.0d0
5416          dZZ_Ci(k)=0.0d0
5417          do j=1,3
5418            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5419            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5420          enddo
5421
5422          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5423          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5424          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5425 c
5426          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5427          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5428        enddo
5429
5430        do k=1,3
5431          dXX_Ctab(k,i)=dXX_Ci(k)
5432          dXX_C1tab(k,i)=dXX_Ci1(k)
5433          dYY_Ctab(k,i)=dYY_Ci(k)
5434          dYY_C1tab(k,i)=dYY_Ci1(k)
5435          dZZ_Ctab(k,i)=dZZ_Ci(k)
5436          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5437          dXX_XYZtab(k,i)=dXX_XYZ(k)
5438          dYY_XYZtab(k,i)=dYY_XYZ(k)
5439          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5440        enddo
5441
5442        do k = 1,3
5443 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5444 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5445 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5446 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5447 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5448 c     &    dt_dci(k)
5449 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5450 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5451          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5452      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5453          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5454      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5455          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5456      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5457        enddo
5458 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5459 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5460
5461 C to check gradient call subroutine check_grad
5462
5463     1 continue
5464       enddo
5465       return
5466       end
5467 c------------------------------------------------------------------------------
5468       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5469       implicit none
5470       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5471      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5472       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5473      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5474      &   + x(10)*yy*zz
5475       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5476      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5477      & + x(20)*yy*zz
5478       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5479      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5480      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5481      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5482      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5483      &  +x(40)*xx*yy*zz
5484       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5485      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5486      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5487      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5488      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5489      &  +x(60)*xx*yy*zz
5490       dsc_i   = 0.743d0+x(61)
5491       dp2_i   = 1.9d0+x(62)
5492       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5493      &          *(xx*cost2+yy*sint2))
5494       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5495      &          *(xx*cost2-yy*sint2))
5496       s1=(1+x(63))/(0.1d0 + dscp1)
5497       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5498       s2=(1+x(65))/(0.1d0 + dscp2)
5499       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5500       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5501      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5502       enesc=sumene
5503       return
5504       end
5505 #endif
5506 c------------------------------------------------------------------------------
5507       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5508 C
5509 C This procedure calculates two-body contact function g(rij) and its derivative:
5510 C
5511 C           eps0ij                                     !       x < -1
5512 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5513 C            0                                         !       x > 1
5514 C
5515 C where x=(rij-r0ij)/delta
5516 C
5517 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5518 C
5519       implicit none
5520       double precision rij,r0ij,eps0ij,fcont,fprimcont
5521       double precision x,x2,x4,delta
5522 c     delta=0.02D0*r0ij
5523 c      delta=0.2D0*r0ij
5524       x=(rij-r0ij)/delta
5525       if (x.lt.-1.0D0) then
5526         fcont=eps0ij
5527         fprimcont=0.0D0
5528       else if (x.le.1.0D0) then
5529         x2=x*x
5530         x4=x2*x2
5531         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5532         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5533       else
5534         fcont=0.0D0
5535         fprimcont=0.0D0
5536       endif
5537       return
5538       end
5539 c------------------------------------------------------------------------------
5540       subroutine splinthet(theti,delta,ss,ssder)
5541       implicit real*8 (a-h,o-z)
5542       include 'DIMENSIONS'
5543       include 'COMMON.VAR'
5544       include 'COMMON.GEO'
5545       thetup=pi-delta
5546       thetlow=delta
5547       if (theti.gt.pipol) then
5548         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5549       else
5550         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5551         ssder=-ssder
5552       endif
5553       return
5554       end
5555 c------------------------------------------------------------------------------
5556       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5557       implicit none
5558       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5559       double precision ksi,ksi2,ksi3,a1,a2,a3
5560       a1=fprim0*delta/(f1-f0)
5561       a2=3.0d0-2.0d0*a1
5562       a3=a1-2.0d0
5563       ksi=(x-x0)/delta
5564       ksi2=ksi*ksi
5565       ksi3=ksi2*ksi
5566       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5567       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5568       return
5569       end
5570 c------------------------------------------------------------------------------
5571       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5572       implicit none
5573       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5574       double precision ksi,ksi2,ksi3,a1,a2,a3
5575       ksi=(x-x0)/delta
5576       ksi2=ksi*ksi
5577       ksi3=ksi2*ksi
5578       a1=fprim0x*delta
5579       a2=3*(f1x-f0x)-2*fprim0x*delta
5580       a3=fprim0x*delta-2*(f1x-f0x)
5581       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5582       return
5583       end
5584 C-----------------------------------------------------------------------------
5585 #ifdef CRYST_TOR
5586 C-----------------------------------------------------------------------------
5587       subroutine etor(etors,edihcnstr)
5588       implicit real*8 (a-h,o-z)
5589       include 'DIMENSIONS'
5590       include 'COMMON.VAR'
5591       include 'COMMON.GEO'
5592       include 'COMMON.LOCAL'
5593       include 'COMMON.TORSION'
5594       include 'COMMON.INTERACT'
5595       include 'COMMON.DERIV'
5596       include 'COMMON.CHAIN'
5597       include 'COMMON.NAMES'
5598       include 'COMMON.IOUNITS'
5599       include 'COMMON.FFIELD'
5600       include 'COMMON.TORCNSTR'
5601       include 'COMMON.CONTROL'
5602       logical lprn
5603 C Set lprn=.true. for debugging
5604       lprn=.false.
5605 c      lprn=.true.
5606       etors=0.0D0
5607       do i=iphi_start,iphi_end
5608       etors_ii=0.0D0
5609         itori=itortyp(itype(i-2))
5610         itori1=itortyp(itype(i-1))
5611         phii=phi(i)
5612         gloci=0.0D0
5613 C Proline-Proline pair is a special case...
5614         if (itori.eq.3 .and. itori1.eq.3) then
5615           if (phii.gt.-dwapi3) then
5616             cosphi=dcos(3*phii)
5617             fac=1.0D0/(1.0D0-cosphi)
5618             etorsi=v1(1,3,3)*fac
5619             etorsi=etorsi+etorsi
5620             etors=etors+etorsi-v1(1,3,3)
5621             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5622             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5623           endif
5624           do j=1,3
5625             v1ij=v1(j+1,itori,itori1)
5626             v2ij=v2(j+1,itori,itori1)
5627             cosphi=dcos(j*phii)
5628             sinphi=dsin(j*phii)
5629             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5630             if (energy_dec) etors_ii=etors_ii+
5631      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5632             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5633           enddo
5634         else
5635           do j=1,nterm_old
5636             v1ij=v1(j,itori,itori1)
5637             v2ij=v2(j,itori,itori1)
5638             cosphi=dcos(j*phii)
5639             sinphi=dsin(j*phii)
5640             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5641             if (energy_dec) etors_ii=etors_ii+
5642      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5643             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5644           enddo
5645         endif
5646         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5647      &        'etor',i,etors_ii
5648         if (lprn)
5649      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5650      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5651      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5652         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5653         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5654       enddo
5655 ! 6/20/98 - dihedral angle constraints
5656       edihcnstr=0.0d0
5657       do i=1,ndih_constr
5658         itori=idih_constr(i)
5659         phii=phi(itori)
5660         difi=phii-phi0(i)
5661         if (difi.gt.drange(i)) then
5662           difi=difi-drange(i)
5663           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5664           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5665         else if (difi.lt.-drange(i)) then
5666           difi=difi+drange(i)
5667           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5668           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5669         endif
5670 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5671 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5672       enddo
5673 !      write (iout,*) 'edihcnstr',edihcnstr
5674       return
5675       end
5676 c------------------------------------------------------------------------------
5677       subroutine etor_d(etors_d)
5678       etors_d=0.0d0
5679       return
5680       end
5681 c----------------------------------------------------------------------------
5682 #else
5683       subroutine etor(etors,edihcnstr)
5684       implicit real*8 (a-h,o-z)
5685       include 'DIMENSIONS'
5686       include 'COMMON.VAR'
5687       include 'COMMON.GEO'
5688       include 'COMMON.LOCAL'
5689       include 'COMMON.TORSION'
5690       include 'COMMON.INTERACT'
5691       include 'COMMON.DERIV'
5692       include 'COMMON.CHAIN'
5693       include 'COMMON.NAMES'
5694       include 'COMMON.IOUNITS'
5695       include 'COMMON.FFIELD'
5696       include 'COMMON.TORCNSTR'
5697       include 'COMMON.CONTROL'
5698       logical lprn
5699 C Set lprn=.true. for debugging
5700       lprn=.false.
5701 c     lprn=.true.
5702       etors=0.0D0
5703       do i=iphi_start,iphi_end
5704       etors_ii=0.0D0
5705         itori=itortyp(itype(i-2))
5706         itori1=itortyp(itype(i-1))
5707         phii=phi(i)
5708         gloci=0.0D0
5709 C Regular cosine and sine terms
5710         do j=1,nterm(itori,itori1)
5711           v1ij=v1(j,itori,itori1)
5712           v2ij=v2(j,itori,itori1)
5713           cosphi=dcos(j*phii)
5714           sinphi=dsin(j*phii)
5715           etors=etors+v1ij*cosphi+v2ij*sinphi
5716           if (energy_dec) etors_ii=etors_ii+
5717      &                v1ij*cosphi+v2ij*sinphi
5718           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5719         enddo
5720 C Lorentz terms
5721 C                         v1
5722 C  E = SUM ----------------------------------- - v1
5723 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5724 C
5725         cosphi=dcos(0.5d0*phii)
5726         sinphi=dsin(0.5d0*phii)
5727         do j=1,nlor(itori,itori1)
5728           vl1ij=vlor1(j,itori,itori1)
5729           vl2ij=vlor2(j,itori,itori1)
5730           vl3ij=vlor3(j,itori,itori1)
5731           pom=vl2ij*cosphi+vl3ij*sinphi
5732           pom1=1.0d0/(pom*pom+1.0d0)
5733           etors=etors+vl1ij*pom1
5734           if (energy_dec) etors_ii=etors_ii+
5735      &                vl1ij*pom1
5736           pom=-pom*pom1*pom1
5737           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5738         enddo
5739 C Subtract the constant term
5740         etors=etors-v0(itori,itori1)
5741           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5742      &         'etor',i,etors_ii-v0(itori,itori1)
5743         if (lprn)
5744      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5745      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5746      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5747         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5748 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5749       enddo
5750 ! 6/20/98 - dihedral angle constraints
5751       edihcnstr=0.0d0
5752 c      do i=1,ndih_constr
5753       do i=idihconstr_start,idihconstr_end
5754         itori=idih_constr(i)
5755         phii=phi(itori)
5756         difi=pinorm(phii-phi0(i))
5757         if (difi.gt.drange(i)) then
5758           difi=difi-drange(i)
5759           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5760           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5761         else if (difi.lt.-drange(i)) then
5762           difi=difi+drange(i)
5763           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5764           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5765         else
5766           difi=0.0
5767         endif
5768 c        write (iout,*) "gloci", gloc(i-3,icg)
5769 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5770 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5771 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5772       enddo
5773 cd       write (iout,*) 'edihcnstr',edihcnstr
5774       return
5775       end
5776 c----------------------------------------------------------------------------
5777       subroutine etor_d(etors_d)
5778 C 6/23/01 Compute double torsional energy
5779       implicit real*8 (a-h,o-z)
5780       include 'DIMENSIONS'
5781       include 'COMMON.VAR'
5782       include 'COMMON.GEO'
5783       include 'COMMON.LOCAL'
5784       include 'COMMON.TORSION'
5785       include 'COMMON.INTERACT'
5786       include 'COMMON.DERIV'
5787       include 'COMMON.CHAIN'
5788       include 'COMMON.NAMES'
5789       include 'COMMON.IOUNITS'
5790       include 'COMMON.FFIELD'
5791       include 'COMMON.TORCNSTR'
5792       logical lprn
5793 C Set lprn=.true. for debugging
5794       lprn=.false.
5795 c     lprn=.true.
5796       etors_d=0.0D0
5797       do i=iphid_start,iphid_end
5798         itori=itortyp(itype(i-2))
5799         itori1=itortyp(itype(i-1))
5800         itori2=itortyp(itype(i))
5801         phii=phi(i)
5802         phii1=phi(i+1)
5803         gloci1=0.0D0
5804         gloci2=0.0D0
5805         do j=1,ntermd_1(itori,itori1,itori2)
5806           v1cij=v1c(1,j,itori,itori1,itori2)
5807           v1sij=v1s(1,j,itori,itori1,itori2)
5808           v2cij=v1c(2,j,itori,itori1,itori2)
5809           v2sij=v1s(2,j,itori,itori1,itori2)
5810           cosphi1=dcos(j*phii)
5811           sinphi1=dsin(j*phii)
5812           cosphi2=dcos(j*phii1)
5813           sinphi2=dsin(j*phii1)
5814           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5815      &     v2cij*cosphi2+v2sij*sinphi2
5816           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5817           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5818         enddo
5819         do k=2,ntermd_2(itori,itori1,itori2)
5820           do l=1,k-1
5821             v1cdij = v2c(k,l,itori,itori1,itori2)
5822             v2cdij = v2c(l,k,itori,itori1,itori2)
5823             v1sdij = v2s(k,l,itori,itori1,itori2)
5824             v2sdij = v2s(l,k,itori,itori1,itori2)
5825             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5826             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5827             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5828             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5829             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5830      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5831             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5832      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5833             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5834      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5835           enddo
5836         enddo
5837         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5838         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5839 c        write (iout,*) "gloci", gloc(i-3,icg)
5840       enddo
5841       return
5842       end
5843 #endif
5844 c------------------------------------------------------------------------------
5845       subroutine eback_sc_corr(esccor)
5846 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5847 c        conformational states; temporarily implemented as differences
5848 c        between UNRES torsional potentials (dependent on three types of
5849 c        residues) and the torsional potentials dependent on all 20 types
5850 c        of residues computed from AM1  energy surfaces of terminally-blocked
5851 c        amino-acid residues.
5852       implicit real*8 (a-h,o-z)
5853       include 'DIMENSIONS'
5854       include 'COMMON.VAR'
5855       include 'COMMON.GEO'
5856       include 'COMMON.LOCAL'
5857       include 'COMMON.TORSION'
5858       include 'COMMON.SCCOR'
5859       include 'COMMON.INTERACT'
5860       include 'COMMON.DERIV'
5861       include 'COMMON.CHAIN'
5862       include 'COMMON.NAMES'
5863       include 'COMMON.IOUNITS'
5864       include 'COMMON.FFIELD'
5865       include 'COMMON.CONTROL'
5866       logical lprn
5867 C Set lprn=.true. for debugging
5868       lprn=.false.
5869 c      lprn=.true.
5870 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5871       esccor=0.0D0
5872       do i=iphi_start-1,iphi_end+1
5873         esccor_ii=0.0D0
5874         isccori=isccortyp(itype(i-2))
5875         isccori1=isccortyp(itype(i-1))
5876         phii=phi(i)
5877 cccc  Added 9 May 2012
5878 cc Tauangle is torsional engle depending on the value of first digit
5879 c(see comment below)
5880 cc Omicron is flat angle depending on the value of first digit
5881 c(see comment below)
5882
5883
5884         do intertyp=1,3 !intertyp
5885 cc Added 09 May 2012 (Adasko)
5886 cc  Intertyp means interaction type of backbone mainchain correlation:
5887 c   1 = SC...Ca...Ca...Ca
5888 c   2 = Ca...Ca...Ca...SC
5889 c   3 = SC...Ca...Ca...SCi
5890         gloci=0.0D0
5891         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5892      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
5893      &      (itype(i-1).eq.21)))
5894      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5895      &     .or.(itype(i-2).eq.21)))
5896      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5897      &      (itype(i-1).eq.21)))) cycle
5898         if ((intertyp.eq.2).and.(i.le.iphi_start-1)) cycle
5899         if ((intertyp.eq.1).and.(i.ge.iphi_end+1)) cycle
5900         do j=1,nterm_sccor(isccori,isccori1)
5901           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5902           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5903           cosphi=dcos(j*tauangle(intertyp,i))
5904           sinphi=dsin(j*tauangle(intertyp,i))
5905           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5906           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5907         enddo
5908         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5909 c        write (iout,*) "WTF",intertyp,i,itype(i),
5910 c     &gloc_sc(intertyp,i-3,icg)
5911         if (lprn)
5912      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5913      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5914      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
5915      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
5916         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5917        enddo !intertyp
5918       enddo
5919 c        do i=1,nres
5920 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
5921 c        enddo
5922       return
5923       end
5924 c----------------------------------------------------------------------------
5925       subroutine multibody(ecorr)
5926 C This subroutine calculates multi-body contributions to energy following
5927 C the idea of Skolnick et al. If side chains I and J make a contact and
5928 C at the same time side chains I+1 and J+1 make a contact, an extra
5929 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5930       implicit real*8 (a-h,o-z)
5931       include 'DIMENSIONS'
5932       include 'COMMON.IOUNITS'
5933       include 'COMMON.DERIV'
5934       include 'COMMON.INTERACT'
5935       include 'COMMON.CONTACTS'
5936       double precision gx(3),gx1(3)
5937       logical lprn
5938
5939 C Set lprn=.true. for debugging
5940       lprn=.false.
5941
5942       if (lprn) then
5943         write (iout,'(a)') 'Contact function values:'
5944         do i=nnt,nct-2
5945           write (iout,'(i2,20(1x,i2,f10.5))')
5946      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5947         enddo
5948       endif
5949       ecorr=0.0D0
5950       do i=nnt,nct
5951         do j=1,3
5952           gradcorr(j,i)=0.0D0
5953           gradxorr(j,i)=0.0D0
5954         enddo
5955       enddo
5956       do i=nnt,nct-2
5957
5958         DO ISHIFT = 3,4
5959
5960         i1=i+ishift
5961         num_conti=num_cont(i)
5962         num_conti1=num_cont(i1)
5963         do jj=1,num_conti
5964           j=jcont(jj,i)
5965           do kk=1,num_conti1
5966             j1=jcont(kk,i1)
5967             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5968 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5969 cd   &                   ' ishift=',ishift
5970 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5971 C The system gains extra energy.
5972               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5973             endif   ! j1==j+-ishift
5974           enddo     ! kk
5975         enddo       ! jj
5976
5977         ENDDO ! ISHIFT
5978
5979       enddo         ! i
5980       return
5981       end
5982 c------------------------------------------------------------------------------
5983       double precision function esccorr(i,j,k,l,jj,kk)
5984       implicit real*8 (a-h,o-z)
5985       include 'DIMENSIONS'
5986       include 'COMMON.IOUNITS'
5987       include 'COMMON.DERIV'
5988       include 'COMMON.INTERACT'
5989       include 'COMMON.CONTACTS'
5990       double precision gx(3),gx1(3)
5991       logical lprn
5992       lprn=.false.
5993       eij=facont(jj,i)
5994       ekl=facont(kk,k)
5995 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5996 C Calculate the multi-body contribution to energy.
5997 C Calculate multi-body contributions to the gradient.
5998 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5999 cd   & k,l,(gacont(m,kk,k),m=1,3)
6000       do m=1,3
6001         gx(m) =ekl*gacont(m,jj,i)
6002         gx1(m)=eij*gacont(m,kk,k)
6003         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6004         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6005         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6006         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6007       enddo
6008       do m=i,j-1
6009         do ll=1,3
6010           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6011         enddo
6012       enddo
6013       do m=k,l-1
6014         do ll=1,3
6015           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6016         enddo
6017       enddo
6018       esccorr=-eij*ekl
6019       return
6020       end
6021 c------------------------------------------------------------------------------
6022       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6023 C This subroutine calculates multi-body contributions to hydrogen-bonding
6024       implicit real*8 (a-h,o-z)
6025       include 'DIMENSIONS'
6026       include 'COMMON.IOUNITS'
6027 #ifdef MPI
6028       include "mpif.h"
6029       parameter (max_cont=maxconts)
6030       parameter (max_dim=26)
6031       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6032       double precision zapas(max_dim,maxconts,max_fg_procs),
6033      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6034       common /przechowalnia/ zapas
6035       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6036      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6037 #endif
6038       include 'COMMON.SETUP'
6039       include 'COMMON.FFIELD'
6040       include 'COMMON.DERIV'
6041       include 'COMMON.INTERACT'
6042       include 'COMMON.CONTACTS'
6043       include 'COMMON.CONTROL'
6044       include 'COMMON.LOCAL'
6045       double precision gx(3),gx1(3),time00
6046       logical lprn,ldone
6047
6048 C Set lprn=.true. for debugging
6049       lprn=.false.
6050 #ifdef MPI
6051       n_corr=0
6052       n_corr1=0
6053       if (nfgtasks.le.1) goto 30
6054       if (lprn) then
6055         write (iout,'(a)') 'Contact function values before RECEIVE:'
6056         do i=nnt,nct-2
6057           write (iout,'(2i3,50(1x,i2,f5.2))')
6058      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6059      &    j=1,num_cont_hb(i))
6060         enddo
6061       endif
6062       call flush(iout)
6063       do i=1,ntask_cont_from
6064         ncont_recv(i)=0
6065       enddo
6066       do i=1,ntask_cont_to
6067         ncont_sent(i)=0
6068       enddo
6069 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6070 c     & ntask_cont_to
6071 C Make the list of contacts to send to send to other procesors
6072 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6073 c      call flush(iout)
6074       do i=iturn3_start,iturn3_end
6075 c        write (iout,*) "make contact list turn3",i," num_cont",
6076 c     &    num_cont_hb(i)
6077         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6078       enddo
6079       do i=iturn4_start,iturn4_end
6080 c        write (iout,*) "make contact list turn4",i," num_cont",
6081 c     &   num_cont_hb(i)
6082         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6083       enddo
6084       do ii=1,nat_sent
6085         i=iat_sent(ii)
6086 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6087 c     &    num_cont_hb(i)
6088         do j=1,num_cont_hb(i)
6089         do k=1,4
6090           jjc=jcont_hb(j,i)
6091           iproc=iint_sent_local(k,jjc,ii)
6092 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6093           if (iproc.gt.0) then
6094             ncont_sent(iproc)=ncont_sent(iproc)+1
6095             nn=ncont_sent(iproc)
6096             zapas(1,nn,iproc)=i
6097             zapas(2,nn,iproc)=jjc
6098             zapas(3,nn,iproc)=facont_hb(j,i)
6099             zapas(4,nn,iproc)=ees0p(j,i)
6100             zapas(5,nn,iproc)=ees0m(j,i)
6101             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6102             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6103             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6104             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6105             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6106             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6107             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6108             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6109             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6110             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6111             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6112             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6113             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6114             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6115             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6116             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6117             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6118             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6119             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6120             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6121             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6122           endif
6123         enddo
6124         enddo
6125       enddo
6126       if (lprn) then
6127       write (iout,*)
6128      &  "Numbers of contacts to be sent to other processors",
6129      &  (ncont_sent(i),i=1,ntask_cont_to)
6130       write (iout,*) "Contacts sent"
6131       do ii=1,ntask_cont_to
6132         nn=ncont_sent(ii)
6133         iproc=itask_cont_to(ii)
6134         write (iout,*) nn," contacts to processor",iproc,
6135      &   " of CONT_TO_COMM group"
6136         do i=1,nn
6137           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6138         enddo
6139       enddo
6140       call flush(iout)
6141       endif
6142       CorrelType=477
6143       CorrelID=fg_rank+1
6144       CorrelType1=478
6145       CorrelID1=nfgtasks+fg_rank+1
6146       ireq=0
6147 C Receive the numbers of needed contacts from other processors
6148       do ii=1,ntask_cont_from
6149         iproc=itask_cont_from(ii)
6150         ireq=ireq+1
6151         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6152      &    FG_COMM,req(ireq),IERR)
6153       enddo
6154 c      write (iout,*) "IRECV ended"
6155 c      call flush(iout)
6156 C Send the number of contacts needed by other processors
6157       do ii=1,ntask_cont_to
6158         iproc=itask_cont_to(ii)
6159         ireq=ireq+1
6160         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6161      &    FG_COMM,req(ireq),IERR)
6162       enddo
6163 c      write (iout,*) "ISEND ended"
6164 c      write (iout,*) "number of requests (nn)",ireq
6165       call flush(iout)
6166       if (ireq.gt.0)
6167      &  call MPI_Waitall(ireq,req,status_array,ierr)
6168 c      write (iout,*)
6169 c     &  "Numbers of contacts to be received from other processors",
6170 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6171 c      call flush(iout)
6172 C Receive contacts
6173       ireq=0
6174       do ii=1,ntask_cont_from
6175         iproc=itask_cont_from(ii)
6176         nn=ncont_recv(ii)
6177 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6178 c     &   " of CONT_TO_COMM group"
6179         call flush(iout)
6180         if (nn.gt.0) then
6181           ireq=ireq+1
6182           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6183      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6184 c          write (iout,*) "ireq,req",ireq,req(ireq)
6185         endif
6186       enddo
6187 C Send the contacts to processors that need them
6188       do ii=1,ntask_cont_to
6189         iproc=itask_cont_to(ii)
6190         nn=ncont_sent(ii)
6191 c        write (iout,*) nn," contacts to processor",iproc,
6192 c     &   " of CONT_TO_COMM group"
6193         if (nn.gt.0) then
6194           ireq=ireq+1
6195           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6196      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6197 c          write (iout,*) "ireq,req",ireq,req(ireq)
6198 c          do i=1,nn
6199 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6200 c          enddo
6201         endif
6202       enddo
6203 c      write (iout,*) "number of requests (contacts)",ireq
6204 c      write (iout,*) "req",(req(i),i=1,4)
6205 c      call flush(iout)
6206       if (ireq.gt.0)
6207      & call MPI_Waitall(ireq,req,status_array,ierr)
6208       do iii=1,ntask_cont_from
6209         iproc=itask_cont_from(iii)
6210         nn=ncont_recv(iii)
6211         if (lprn) then
6212         write (iout,*) "Received",nn," contacts from processor",iproc,
6213      &   " of CONT_FROM_COMM group"
6214         call flush(iout)
6215         do i=1,nn
6216           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6217         enddo
6218         call flush(iout)
6219         endif
6220         do i=1,nn
6221           ii=zapas_recv(1,i,iii)
6222 c Flag the received contacts to prevent double-counting
6223           jj=-zapas_recv(2,i,iii)
6224 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6225 c          call flush(iout)
6226           nnn=num_cont_hb(ii)+1
6227           num_cont_hb(ii)=nnn
6228           jcont_hb(nnn,ii)=jj
6229           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6230           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6231           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6232           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6233           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6234           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6235           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6236           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6237           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6238           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6239           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6240           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6241           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6242           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6243           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6244           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6245           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6246           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6247           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6248           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6249           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6250           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6251           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6252           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6253         enddo
6254       enddo
6255       call flush(iout)
6256       if (lprn) then
6257         write (iout,'(a)') 'Contact function values after receive:'
6258         do i=nnt,nct-2
6259           write (iout,'(2i3,50(1x,i3,f5.2))')
6260      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6261      &    j=1,num_cont_hb(i))
6262         enddo
6263         call flush(iout)
6264       endif
6265    30 continue
6266 #endif
6267       if (lprn) then
6268         write (iout,'(a)') 'Contact function values:'
6269         do i=nnt,nct-2
6270           write (iout,'(2i3,50(1x,i3,f5.2))')
6271      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6272      &    j=1,num_cont_hb(i))
6273         enddo
6274       endif
6275       ecorr=0.0D0
6276 C Remove the loop below after debugging !!!
6277       do i=nnt,nct
6278         do j=1,3
6279           gradcorr(j,i)=0.0D0
6280           gradxorr(j,i)=0.0D0
6281         enddo
6282       enddo
6283 C Calculate the local-electrostatic correlation terms
6284       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6285         i1=i+1
6286         num_conti=num_cont_hb(i)
6287         num_conti1=num_cont_hb(i+1)
6288         do jj=1,num_conti
6289           j=jcont_hb(jj,i)
6290           jp=iabs(j)
6291           do kk=1,num_conti1
6292             j1=jcont_hb(kk,i1)
6293             jp1=iabs(j1)
6294 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6295 c     &         ' jj=',jj,' kk=',kk
6296             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6297      &          .or. j.lt.0 .and. j1.gt.0) .and.
6298      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6299 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6300 C The system gains extra energy.
6301               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6302               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6303      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6304               n_corr=n_corr+1
6305             else if (j1.eq.j) then
6306 C Contacts I-J and I-(J+1) occur simultaneously.
6307 C The system loses extra energy.
6308 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6309             endif
6310           enddo ! kk
6311           do kk=1,num_conti
6312             j1=jcont_hb(kk,i)
6313 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6314 c    &         ' jj=',jj,' kk=',kk
6315             if (j1.eq.j+1) then
6316 C Contacts I-J and (I+1)-J occur simultaneously.
6317 C The system loses extra energy.
6318 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6319             endif ! j1==j+1
6320           enddo ! kk
6321         enddo ! jj
6322       enddo ! i
6323       return
6324       end
6325 c------------------------------------------------------------------------------
6326       subroutine add_hb_contact(ii,jj,itask)
6327       implicit real*8 (a-h,o-z)
6328       include "DIMENSIONS"
6329       include "COMMON.IOUNITS"
6330       integer max_cont
6331       integer max_dim
6332       parameter (max_cont=maxconts)
6333       parameter (max_dim=26)
6334       include "COMMON.CONTACTS"
6335       double precision zapas(max_dim,maxconts,max_fg_procs),
6336      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6337       common /przechowalnia/ zapas
6338       integer i,j,ii,jj,iproc,itask(4),nn
6339 c      write (iout,*) "itask",itask
6340       do i=1,2
6341         iproc=itask(i)
6342         if (iproc.gt.0) then
6343           do j=1,num_cont_hb(ii)
6344             jjc=jcont_hb(j,ii)
6345 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6346             if (jjc.eq.jj) then
6347               ncont_sent(iproc)=ncont_sent(iproc)+1
6348               nn=ncont_sent(iproc)
6349               zapas(1,nn,iproc)=ii
6350               zapas(2,nn,iproc)=jjc
6351               zapas(3,nn,iproc)=facont_hb(j,ii)
6352               zapas(4,nn,iproc)=ees0p(j,ii)
6353               zapas(5,nn,iproc)=ees0m(j,ii)
6354               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6355               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6356               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6357               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6358               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6359               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6360               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6361               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6362               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6363               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6364               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6365               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6366               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6367               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6368               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6369               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6370               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6371               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6372               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6373               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6374               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6375               exit
6376             endif
6377           enddo
6378         endif
6379       enddo
6380       return
6381       end
6382 c------------------------------------------------------------------------------
6383       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6384      &  n_corr1)
6385 C This subroutine calculates multi-body contributions to hydrogen-bonding
6386       implicit real*8 (a-h,o-z)
6387       include 'DIMENSIONS'
6388       include 'COMMON.IOUNITS'
6389 #ifdef MPI
6390       include "mpif.h"
6391       parameter (max_cont=maxconts)
6392       parameter (max_dim=70)
6393       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6394       double precision zapas(max_dim,maxconts,max_fg_procs),
6395      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6396       common /przechowalnia/ zapas
6397       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6398      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6399 #endif
6400       include 'COMMON.SETUP'
6401       include 'COMMON.FFIELD'
6402       include 'COMMON.DERIV'
6403       include 'COMMON.LOCAL'
6404       include 'COMMON.INTERACT'
6405       include 'COMMON.CONTACTS'
6406       include 'COMMON.CHAIN'
6407       include 'COMMON.CONTROL'
6408       double precision gx(3),gx1(3)
6409       integer num_cont_hb_old(maxres)
6410       logical lprn,ldone
6411       double precision eello4,eello5,eelo6,eello_turn6
6412       external eello4,eello5,eello6,eello_turn6
6413 C Set lprn=.true. for debugging
6414       lprn=.false.
6415       eturn6=0.0d0
6416 #ifdef MPI
6417       do i=1,nres
6418         num_cont_hb_old(i)=num_cont_hb(i)
6419       enddo
6420       n_corr=0
6421       n_corr1=0
6422       if (nfgtasks.le.1) goto 30
6423       if (lprn) then
6424         write (iout,'(a)') 'Contact function values before RECEIVE:'
6425         do i=nnt,nct-2
6426           write (iout,'(2i3,50(1x,i2,f5.2))')
6427      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6428      &    j=1,num_cont_hb(i))
6429         enddo
6430       endif
6431       call flush(iout)
6432       do i=1,ntask_cont_from
6433         ncont_recv(i)=0
6434       enddo
6435       do i=1,ntask_cont_to
6436         ncont_sent(i)=0
6437       enddo
6438 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6439 c     & ntask_cont_to
6440 C Make the list of contacts to send to send to other procesors
6441       do i=iturn3_start,iturn3_end
6442 c        write (iout,*) "make contact list turn3",i," num_cont",
6443 c     &    num_cont_hb(i)
6444         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6445       enddo
6446       do i=iturn4_start,iturn4_end
6447 c        write (iout,*) "make contact list turn4",i," num_cont",
6448 c     &   num_cont_hb(i)
6449         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6450       enddo
6451       do ii=1,nat_sent
6452         i=iat_sent(ii)
6453 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6454 c     &    num_cont_hb(i)
6455         do j=1,num_cont_hb(i)
6456         do k=1,4
6457           jjc=jcont_hb(j,i)
6458           iproc=iint_sent_local(k,jjc,ii)
6459 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6460           if (iproc.ne.0) then
6461             ncont_sent(iproc)=ncont_sent(iproc)+1
6462             nn=ncont_sent(iproc)
6463             zapas(1,nn,iproc)=i
6464             zapas(2,nn,iproc)=jjc
6465             zapas(3,nn,iproc)=d_cont(j,i)
6466             ind=3
6467             do kk=1,3
6468               ind=ind+1
6469               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6470             enddo
6471             do kk=1,2
6472               do ll=1,2
6473                 ind=ind+1
6474                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6475               enddo
6476             enddo
6477             do jj=1,5
6478               do kk=1,3
6479                 do ll=1,2
6480                   do mm=1,2
6481                     ind=ind+1
6482                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6483                   enddo
6484                 enddo
6485               enddo
6486             enddo
6487           endif
6488         enddo
6489         enddo
6490       enddo
6491       if (lprn) then
6492       write (iout,*)
6493      &  "Numbers of contacts to be sent to other processors",
6494      &  (ncont_sent(i),i=1,ntask_cont_to)
6495       write (iout,*) "Contacts sent"
6496       do ii=1,ntask_cont_to
6497         nn=ncont_sent(ii)
6498         iproc=itask_cont_to(ii)
6499         write (iout,*) nn," contacts to processor",iproc,
6500      &   " of CONT_TO_COMM group"
6501         do i=1,nn
6502           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6503         enddo
6504       enddo
6505       call flush(iout)
6506       endif
6507       CorrelType=477
6508       CorrelID=fg_rank+1
6509       CorrelType1=478
6510       CorrelID1=nfgtasks+fg_rank+1
6511       ireq=0
6512 C Receive the numbers of needed contacts from other processors
6513       do ii=1,ntask_cont_from
6514         iproc=itask_cont_from(ii)
6515         ireq=ireq+1
6516         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6517      &    FG_COMM,req(ireq),IERR)
6518       enddo
6519 c      write (iout,*) "IRECV ended"
6520 c      call flush(iout)
6521 C Send the number of contacts needed by other processors
6522       do ii=1,ntask_cont_to
6523         iproc=itask_cont_to(ii)
6524         ireq=ireq+1
6525         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6526      &    FG_COMM,req(ireq),IERR)
6527       enddo
6528 c      write (iout,*) "ISEND ended"
6529 c      write (iout,*) "number of requests (nn)",ireq
6530       call flush(iout)
6531       if (ireq.gt.0)
6532      &  call MPI_Waitall(ireq,req,status_array,ierr)
6533 c      write (iout,*)
6534 c     &  "Numbers of contacts to be received from other processors",
6535 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6536 c      call flush(iout)
6537 C Receive contacts
6538       ireq=0
6539       do ii=1,ntask_cont_from
6540         iproc=itask_cont_from(ii)
6541         nn=ncont_recv(ii)
6542 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6543 c     &   " of CONT_TO_COMM group"
6544         call flush(iout)
6545         if (nn.gt.0) then
6546           ireq=ireq+1
6547           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6548      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6549 c          write (iout,*) "ireq,req",ireq,req(ireq)
6550         endif
6551       enddo
6552 C Send the contacts to processors that need them
6553       do ii=1,ntask_cont_to
6554         iproc=itask_cont_to(ii)
6555         nn=ncont_sent(ii)
6556 c        write (iout,*) nn," contacts to processor",iproc,
6557 c     &   " of CONT_TO_COMM group"
6558         if (nn.gt.0) then
6559           ireq=ireq+1
6560           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6561      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6562 c          write (iout,*) "ireq,req",ireq,req(ireq)
6563 c          do i=1,nn
6564 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6565 c          enddo
6566         endif
6567       enddo
6568 c      write (iout,*) "number of requests (contacts)",ireq
6569 c      write (iout,*) "req",(req(i),i=1,4)
6570 c      call flush(iout)
6571       if (ireq.gt.0)
6572      & call MPI_Waitall(ireq,req,status_array,ierr)
6573       do iii=1,ntask_cont_from
6574         iproc=itask_cont_from(iii)
6575         nn=ncont_recv(iii)
6576         if (lprn) then
6577         write (iout,*) "Received",nn," contacts from processor",iproc,
6578      &   " of CONT_FROM_COMM group"
6579         call flush(iout)
6580         do i=1,nn
6581           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6582         enddo
6583         call flush(iout)
6584         endif
6585         do i=1,nn
6586           ii=zapas_recv(1,i,iii)
6587 c Flag the received contacts to prevent double-counting
6588           jj=-zapas_recv(2,i,iii)
6589 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6590 c          call flush(iout)
6591           nnn=num_cont_hb(ii)+1
6592           num_cont_hb(ii)=nnn
6593           jcont_hb(nnn,ii)=jj
6594           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6595           ind=3
6596           do kk=1,3
6597             ind=ind+1
6598             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6599           enddo
6600           do kk=1,2
6601             do ll=1,2
6602               ind=ind+1
6603               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6604             enddo
6605           enddo
6606           do jj=1,5
6607             do kk=1,3
6608               do ll=1,2
6609                 do mm=1,2
6610                   ind=ind+1
6611                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6612                 enddo
6613               enddo
6614             enddo
6615           enddo
6616         enddo
6617       enddo
6618       call flush(iout)
6619       if (lprn) then
6620         write (iout,'(a)') 'Contact function values after receive:'
6621         do i=nnt,nct-2
6622           write (iout,'(2i3,50(1x,i3,5f6.3))')
6623      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6624      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6625         enddo
6626         call flush(iout)
6627       endif
6628    30 continue
6629 #endif
6630       if (lprn) then
6631         write (iout,'(a)') 'Contact function values:'
6632         do i=nnt,nct-2
6633           write (iout,'(2i3,50(1x,i2,5f6.3))')
6634      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6635      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6636         enddo
6637       endif
6638       ecorr=0.0D0
6639       ecorr5=0.0d0
6640       ecorr6=0.0d0
6641 C Remove the loop below after debugging !!!
6642       do i=nnt,nct
6643         do j=1,3
6644           gradcorr(j,i)=0.0D0
6645           gradxorr(j,i)=0.0D0
6646         enddo
6647       enddo
6648 C Calculate the dipole-dipole interaction energies
6649       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6650       do i=iatel_s,iatel_e+1
6651         num_conti=num_cont_hb(i)
6652         do jj=1,num_conti
6653           j=jcont_hb(jj,i)
6654 #ifdef MOMENT
6655           call dipole(i,j,jj)
6656 #endif
6657         enddo
6658       enddo
6659       endif
6660 C Calculate the local-electrostatic correlation terms
6661 c                write (iout,*) "gradcorr5 in eello5 before loop"
6662 c                do iii=1,nres
6663 c                  write (iout,'(i5,3f10.5)')
6664 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6665 c                enddo
6666       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6667 c        write (iout,*) "corr loop i",i
6668         i1=i+1
6669         num_conti=num_cont_hb(i)
6670         num_conti1=num_cont_hb(i+1)
6671         do jj=1,num_conti
6672           j=jcont_hb(jj,i)
6673           jp=iabs(j)
6674           do kk=1,num_conti1
6675             j1=jcont_hb(kk,i1)
6676             jp1=iabs(j1)
6677 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6678 c     &         ' jj=',jj,' kk=',kk
6679 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6680             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6681      &          .or. j.lt.0 .and. j1.gt.0) .and.
6682      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6683 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6684 C The system gains extra energy.
6685               n_corr=n_corr+1
6686               sqd1=dsqrt(d_cont(jj,i))
6687               sqd2=dsqrt(d_cont(kk,i1))
6688               sred_geom = sqd1*sqd2
6689               IF (sred_geom.lt.cutoff_corr) THEN
6690                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6691      &            ekont,fprimcont)
6692 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6693 cd     &         ' jj=',jj,' kk=',kk
6694                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6695                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6696                 do l=1,3
6697                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6698                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6699                 enddo
6700                 n_corr1=n_corr1+1
6701 cd               write (iout,*) 'sred_geom=',sred_geom,
6702 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6703 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6704 cd               write (iout,*) "g_contij",g_contij
6705 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6706 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6707                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6708                 if (wcorr4.gt.0.0d0)
6709      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6710                   if (energy_dec.and.wcorr4.gt.0.0d0)
6711      1                 write (iout,'(a6,4i5,0pf7.3)')
6712      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6713 c                write (iout,*) "gradcorr5 before eello5"
6714 c                do iii=1,nres
6715 c                  write (iout,'(i5,3f10.5)')
6716 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6717 c                enddo
6718                 if (wcorr5.gt.0.0d0)
6719      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6720 c                write (iout,*) "gradcorr5 after eello5"
6721 c                do iii=1,nres
6722 c                  write (iout,'(i5,3f10.5)')
6723 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6724 c                enddo
6725                   if (energy_dec.and.wcorr5.gt.0.0d0)
6726      1                 write (iout,'(a6,4i5,0pf7.3)')
6727      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6728 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6729 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6730                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6731      &               .or. wturn6.eq.0.0d0))then
6732 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6733                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6734                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6735      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6736 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6737 cd     &            'ecorr6=',ecorr6
6738 cd                write (iout,'(4e15.5)') sred_geom,
6739 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6740 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6741 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6742                 else if (wturn6.gt.0.0d0
6743      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6744 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6745                   eturn6=eturn6+eello_turn6(i,jj,kk)
6746                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6747      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6748 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6749                 endif
6750               ENDIF
6751 1111          continue
6752             endif
6753           enddo ! kk
6754         enddo ! jj
6755       enddo ! i
6756       do i=1,nres
6757         num_cont_hb(i)=num_cont_hb_old(i)
6758       enddo
6759 c                write (iout,*) "gradcorr5 in eello5"
6760 c                do iii=1,nres
6761 c                  write (iout,'(i5,3f10.5)')
6762 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6763 c                enddo
6764       return
6765       end
6766 c------------------------------------------------------------------------------
6767       subroutine add_hb_contact_eello(ii,jj,itask)
6768       implicit real*8 (a-h,o-z)
6769       include "DIMENSIONS"
6770       include "COMMON.IOUNITS"
6771       integer max_cont
6772       integer max_dim
6773       parameter (max_cont=maxconts)
6774       parameter (max_dim=70)
6775       include "COMMON.CONTACTS"
6776       double precision zapas(max_dim,maxconts,max_fg_procs),
6777      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6778       common /przechowalnia/ zapas
6779       integer i,j,ii,jj,iproc,itask(4),nn
6780 c      write (iout,*) "itask",itask
6781       do i=1,2
6782         iproc=itask(i)
6783         if (iproc.gt.0) then
6784           do j=1,num_cont_hb(ii)
6785             jjc=jcont_hb(j,ii)
6786 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6787             if (jjc.eq.jj) then
6788               ncont_sent(iproc)=ncont_sent(iproc)+1
6789               nn=ncont_sent(iproc)
6790               zapas(1,nn,iproc)=ii
6791               zapas(2,nn,iproc)=jjc
6792               zapas(3,nn,iproc)=d_cont(j,ii)
6793               ind=3
6794               do kk=1,3
6795                 ind=ind+1
6796                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6797               enddo
6798               do kk=1,2
6799                 do ll=1,2
6800                   ind=ind+1
6801                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6802                 enddo
6803               enddo
6804               do jj=1,5
6805                 do kk=1,3
6806                   do ll=1,2
6807                     do mm=1,2
6808                       ind=ind+1
6809                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6810                     enddo
6811                   enddo
6812                 enddo
6813               enddo
6814               exit
6815             endif
6816           enddo
6817         endif
6818       enddo
6819       return
6820       end
6821 c------------------------------------------------------------------------------
6822       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6823       implicit real*8 (a-h,o-z)
6824       include 'DIMENSIONS'
6825       include 'COMMON.IOUNITS'
6826       include 'COMMON.DERIV'
6827       include 'COMMON.INTERACT'
6828       include 'COMMON.CONTACTS'
6829       double precision gx(3),gx1(3)
6830       logical lprn
6831       lprn=.false.
6832       eij=facont_hb(jj,i)
6833       ekl=facont_hb(kk,k)
6834       ees0pij=ees0p(jj,i)
6835       ees0pkl=ees0p(kk,k)
6836       ees0mij=ees0m(jj,i)
6837       ees0mkl=ees0m(kk,k)
6838       ekont=eij*ekl
6839       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6840 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6841 C Following 4 lines for diagnostics.
6842 cd    ees0pkl=0.0D0
6843 cd    ees0pij=1.0D0
6844 cd    ees0mkl=0.0D0
6845 cd    ees0mij=1.0D0
6846 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6847 c     & 'Contacts ',i,j,
6848 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6849 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6850 c     & 'gradcorr_long'
6851 C Calculate the multi-body contribution to energy.
6852 c      ecorr=ecorr+ekont*ees
6853 C Calculate multi-body contributions to the gradient.
6854       coeffpees0pij=coeffp*ees0pij
6855       coeffmees0mij=coeffm*ees0mij
6856       coeffpees0pkl=coeffp*ees0pkl
6857       coeffmees0mkl=coeffm*ees0mkl
6858       do ll=1,3
6859 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6860         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6861      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6862      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6863         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6864      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6865      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6866 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6867         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6868      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6869      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6870         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6871      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6872      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6873         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6874      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6875      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6876         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6877         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6878         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6879      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6880      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6881         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6882         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6883 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6884       enddo
6885 c      write (iout,*)
6886 cgrad      do m=i+1,j-1
6887 cgrad        do ll=1,3
6888 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6889 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6890 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6891 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6892 cgrad        enddo
6893 cgrad      enddo
6894 cgrad      do m=k+1,l-1
6895 cgrad        do ll=1,3
6896 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6897 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6898 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6899 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6900 cgrad        enddo
6901 cgrad      enddo
6902 c      write (iout,*) "ehbcorr",ekont*ees
6903       ehbcorr=ekont*ees
6904       return
6905       end
6906 #ifdef MOMENT
6907 C---------------------------------------------------------------------------
6908       subroutine dipole(i,j,jj)
6909       implicit real*8 (a-h,o-z)
6910       include 'DIMENSIONS'
6911       include 'COMMON.IOUNITS'
6912       include 'COMMON.CHAIN'
6913       include 'COMMON.FFIELD'
6914       include 'COMMON.DERIV'
6915       include 'COMMON.INTERACT'
6916       include 'COMMON.CONTACTS'
6917       include 'COMMON.TORSION'
6918       include 'COMMON.VAR'
6919       include 'COMMON.GEO'
6920       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6921      &  auxmat(2,2)
6922       iti1 = itortyp(itype(i+1))
6923       if (j.lt.nres-1) then
6924         itj1 = itortyp(itype(j+1))
6925       else
6926         itj1=ntortyp+1
6927       endif
6928       do iii=1,2
6929         dipi(iii,1)=Ub2(iii,i)
6930         dipderi(iii)=Ub2der(iii,i)
6931         dipi(iii,2)=b1(iii,iti1)
6932         dipj(iii,1)=Ub2(iii,j)
6933         dipderj(iii)=Ub2der(iii,j)
6934         dipj(iii,2)=b1(iii,itj1)
6935       enddo
6936       kkk=0
6937       do iii=1,2
6938         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6939         do jjj=1,2
6940           kkk=kkk+1
6941           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6942         enddo
6943       enddo
6944       do kkk=1,5
6945         do lll=1,3
6946           mmm=0
6947           do iii=1,2
6948             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6949      &        auxvec(1))
6950             do jjj=1,2
6951               mmm=mmm+1
6952               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6953             enddo
6954           enddo
6955         enddo
6956       enddo
6957       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6958       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6959       do iii=1,2
6960         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6961       enddo
6962       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6963       do iii=1,2
6964         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6965       enddo
6966       return
6967       end
6968 #endif
6969 C---------------------------------------------------------------------------
6970       subroutine calc_eello(i,j,k,l,jj,kk)
6971 C
6972 C This subroutine computes matrices and vectors needed to calculate
6973 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6974 C
6975       implicit real*8 (a-h,o-z)
6976       include 'DIMENSIONS'
6977       include 'COMMON.IOUNITS'
6978       include 'COMMON.CHAIN'
6979       include 'COMMON.DERIV'
6980       include 'COMMON.INTERACT'
6981       include 'COMMON.CONTACTS'
6982       include 'COMMON.TORSION'
6983       include 'COMMON.VAR'
6984       include 'COMMON.GEO'
6985       include 'COMMON.FFIELD'
6986       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6987      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6988       logical lprn
6989       common /kutas/ lprn
6990 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6991 cd     & ' jj=',jj,' kk=',kk
6992 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6993 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6994 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6995       do iii=1,2
6996         do jjj=1,2
6997           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6998           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6999         enddo
7000       enddo
7001       call transpose2(aa1(1,1),aa1t(1,1))
7002       call transpose2(aa2(1,1),aa2t(1,1))
7003       do kkk=1,5
7004         do lll=1,3
7005           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7006      &      aa1tder(1,1,lll,kkk))
7007           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7008      &      aa2tder(1,1,lll,kkk))
7009         enddo
7010       enddo
7011       if (l.eq.j+1) then
7012 C parallel orientation of the two CA-CA-CA frames.
7013         if (i.gt.1) then
7014           iti=itortyp(itype(i))
7015         else
7016           iti=ntortyp+1
7017         endif
7018         itk1=itortyp(itype(k+1))
7019         itj=itortyp(itype(j))
7020         if (l.lt.nres-1) then
7021           itl1=itortyp(itype(l+1))
7022         else
7023           itl1=ntortyp+1
7024         endif
7025 C A1 kernel(j+1) A2T
7026 cd        do iii=1,2
7027 cd          write (iout,'(3f10.5,5x,3f10.5)')
7028 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7029 cd        enddo
7030         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7031      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7032      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7033 C Following matrices are needed only for 6-th order cumulants
7034         IF (wcorr6.gt.0.0d0) THEN
7035         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7036      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7037      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7038         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7039      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7040      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7041      &   ADtEAderx(1,1,1,1,1,1))
7042         lprn=.false.
7043         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7044      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7045      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7046      &   ADtEA1derx(1,1,1,1,1,1))
7047         ENDIF
7048 C End 6-th order cumulants
7049 cd        lprn=.false.
7050 cd        if (lprn) then
7051 cd        write (2,*) 'In calc_eello6'
7052 cd        do iii=1,2
7053 cd          write (2,*) 'iii=',iii
7054 cd          do kkk=1,5
7055 cd            write (2,*) 'kkk=',kkk
7056 cd            do jjj=1,2
7057 cd              write (2,'(3(2f10.5),5x)')
7058 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7059 cd            enddo
7060 cd          enddo
7061 cd        enddo
7062 cd        endif
7063         call transpose2(EUgder(1,1,k),auxmat(1,1))
7064         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7065         call transpose2(EUg(1,1,k),auxmat(1,1))
7066         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7067         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7068         do iii=1,2
7069           do kkk=1,5
7070             do lll=1,3
7071               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7072      &          EAEAderx(1,1,lll,kkk,iii,1))
7073             enddo
7074           enddo
7075         enddo
7076 C A1T kernel(i+1) A2
7077         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7078      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7079      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7080 C Following matrices are needed only for 6-th order cumulants
7081         IF (wcorr6.gt.0.0d0) THEN
7082         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7083      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7084      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7085         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7086      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7087      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7088      &   ADtEAderx(1,1,1,1,1,2))
7089         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7090      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7091      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7092      &   ADtEA1derx(1,1,1,1,1,2))
7093         ENDIF
7094 C End 6-th order cumulants
7095         call transpose2(EUgder(1,1,l),auxmat(1,1))
7096         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7097         call transpose2(EUg(1,1,l),auxmat(1,1))
7098         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7099         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7100         do iii=1,2
7101           do kkk=1,5
7102             do lll=1,3
7103               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7104      &          EAEAderx(1,1,lll,kkk,iii,2))
7105             enddo
7106           enddo
7107         enddo
7108 C AEAb1 and AEAb2
7109 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7110 C They are needed only when the fifth- or the sixth-order cumulants are
7111 C indluded.
7112         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7113         call transpose2(AEA(1,1,1),auxmat(1,1))
7114         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7115         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7116         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7117         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7118         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7119         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7120         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7121         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7122         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7123         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7124         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7125         call transpose2(AEA(1,1,2),auxmat(1,1))
7126         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7127         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7128         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7129         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7130         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7131         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7132         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7133         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7134         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7135         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7136         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7137 C Calculate the Cartesian derivatives of the vectors.
7138         do iii=1,2
7139           do kkk=1,5
7140             do lll=1,3
7141               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7142               call matvec2(auxmat(1,1),b1(1,iti),
7143      &          AEAb1derx(1,lll,kkk,iii,1,1))
7144               call matvec2(auxmat(1,1),Ub2(1,i),
7145      &          AEAb2derx(1,lll,kkk,iii,1,1))
7146               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7147      &          AEAb1derx(1,lll,kkk,iii,2,1))
7148               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7149      &          AEAb2derx(1,lll,kkk,iii,2,1))
7150               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7151               call matvec2(auxmat(1,1),b1(1,itj),
7152      &          AEAb1derx(1,lll,kkk,iii,1,2))
7153               call matvec2(auxmat(1,1),Ub2(1,j),
7154      &          AEAb2derx(1,lll,kkk,iii,1,2))
7155               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7156      &          AEAb1derx(1,lll,kkk,iii,2,2))
7157               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7158      &          AEAb2derx(1,lll,kkk,iii,2,2))
7159             enddo
7160           enddo
7161         enddo
7162         ENDIF
7163 C End vectors
7164       else
7165 C Antiparallel orientation of the two CA-CA-CA frames.
7166         if (i.gt.1) then
7167           iti=itortyp(itype(i))
7168         else
7169           iti=ntortyp+1
7170         endif
7171         itk1=itortyp(itype(k+1))
7172         itl=itortyp(itype(l))
7173         itj=itortyp(itype(j))
7174         if (j.lt.nres-1) then
7175           itj1=itortyp(itype(j+1))
7176         else
7177           itj1=ntortyp+1
7178         endif
7179 C A2 kernel(j-1)T A1T
7180         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7181      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7182      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7183 C Following matrices are needed only for 6-th order cumulants
7184         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7185      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7186         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7187      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7188      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7189         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7190      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7191      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7192      &   ADtEAderx(1,1,1,1,1,1))
7193         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7194      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7195      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7196      &   ADtEA1derx(1,1,1,1,1,1))
7197         ENDIF
7198 C End 6-th order cumulants
7199         call transpose2(EUgder(1,1,k),auxmat(1,1))
7200         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7201         call transpose2(EUg(1,1,k),auxmat(1,1))
7202         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7203         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7204         do iii=1,2
7205           do kkk=1,5
7206             do lll=1,3
7207               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7208      &          EAEAderx(1,1,lll,kkk,iii,1))
7209             enddo
7210           enddo
7211         enddo
7212 C A2T kernel(i+1)T A1
7213         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7214      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7215      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7216 C Following matrices are needed only for 6-th order cumulants
7217         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7218      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7219         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7220      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7221      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7222         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7223      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7224      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7225      &   ADtEAderx(1,1,1,1,1,2))
7226         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7227      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7228      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7229      &   ADtEA1derx(1,1,1,1,1,2))
7230         ENDIF
7231 C End 6-th order cumulants
7232         call transpose2(EUgder(1,1,j),auxmat(1,1))
7233         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7234         call transpose2(EUg(1,1,j),auxmat(1,1))
7235         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7236         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7237         do iii=1,2
7238           do kkk=1,5
7239             do lll=1,3
7240               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7241      &          EAEAderx(1,1,lll,kkk,iii,2))
7242             enddo
7243           enddo
7244         enddo
7245 C AEAb1 and AEAb2
7246 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7247 C They are needed only when the fifth- or the sixth-order cumulants are
7248 C indluded.
7249         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7250      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7251         call transpose2(AEA(1,1,1),auxmat(1,1))
7252         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7253         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7254         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7255         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7256         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7257         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7258         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7259         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7260         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7261         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7262         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7263         call transpose2(AEA(1,1,2),auxmat(1,1))
7264         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7265         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7266         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7267         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7268         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7269         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7270         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7271         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7272         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7273         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7274         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7275 C Calculate the Cartesian derivatives of the vectors.
7276         do iii=1,2
7277           do kkk=1,5
7278             do lll=1,3
7279               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7280               call matvec2(auxmat(1,1),b1(1,iti),
7281      &          AEAb1derx(1,lll,kkk,iii,1,1))
7282               call matvec2(auxmat(1,1),Ub2(1,i),
7283      &          AEAb2derx(1,lll,kkk,iii,1,1))
7284               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7285      &          AEAb1derx(1,lll,kkk,iii,2,1))
7286               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7287      &          AEAb2derx(1,lll,kkk,iii,2,1))
7288               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7289               call matvec2(auxmat(1,1),b1(1,itl),
7290      &          AEAb1derx(1,lll,kkk,iii,1,2))
7291               call matvec2(auxmat(1,1),Ub2(1,l),
7292      &          AEAb2derx(1,lll,kkk,iii,1,2))
7293               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7294      &          AEAb1derx(1,lll,kkk,iii,2,2))
7295               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7296      &          AEAb2derx(1,lll,kkk,iii,2,2))
7297             enddo
7298           enddo
7299         enddo
7300         ENDIF
7301 C End vectors
7302       endif
7303       return
7304       end
7305 C---------------------------------------------------------------------------
7306       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7307      &  KK,KKderg,AKA,AKAderg,AKAderx)
7308       implicit none
7309       integer nderg
7310       logical transp
7311       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7312      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7313      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7314       integer iii,kkk,lll
7315       integer jjj,mmm
7316       logical lprn
7317       common /kutas/ lprn
7318       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7319       do iii=1,nderg
7320         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7321      &    AKAderg(1,1,iii))
7322       enddo
7323 cd      if (lprn) write (2,*) 'In kernel'
7324       do kkk=1,5
7325 cd        if (lprn) write (2,*) 'kkk=',kkk
7326         do lll=1,3
7327           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7328      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7329 cd          if (lprn) then
7330 cd            write (2,*) 'lll=',lll
7331 cd            write (2,*) 'iii=1'
7332 cd            do jjj=1,2
7333 cd              write (2,'(3(2f10.5),5x)')
7334 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7335 cd            enddo
7336 cd          endif
7337           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7338      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7339 cd          if (lprn) then
7340 cd            write (2,*) 'lll=',lll
7341 cd            write (2,*) 'iii=2'
7342 cd            do jjj=1,2
7343 cd              write (2,'(3(2f10.5),5x)')
7344 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7345 cd            enddo
7346 cd          endif
7347         enddo
7348       enddo
7349       return
7350       end
7351 C---------------------------------------------------------------------------
7352       double precision function eello4(i,j,k,l,jj,kk)
7353       implicit real*8 (a-h,o-z)
7354       include 'DIMENSIONS'
7355       include 'COMMON.IOUNITS'
7356       include 'COMMON.CHAIN'
7357       include 'COMMON.DERIV'
7358       include 'COMMON.INTERACT'
7359       include 'COMMON.CONTACTS'
7360       include 'COMMON.TORSION'
7361       include 'COMMON.VAR'
7362       include 'COMMON.GEO'
7363       double precision pizda(2,2),ggg1(3),ggg2(3)
7364 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7365 cd        eello4=0.0d0
7366 cd        return
7367 cd      endif
7368 cd      print *,'eello4:',i,j,k,l,jj,kk
7369 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7370 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7371 cold      eij=facont_hb(jj,i)
7372 cold      ekl=facont_hb(kk,k)
7373 cold      ekont=eij*ekl
7374       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7375 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7376       gcorr_loc(k-1)=gcorr_loc(k-1)
7377      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7378       if (l.eq.j+1) then
7379         gcorr_loc(l-1)=gcorr_loc(l-1)
7380      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7381       else
7382         gcorr_loc(j-1)=gcorr_loc(j-1)
7383      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7384       endif
7385       do iii=1,2
7386         do kkk=1,5
7387           do lll=1,3
7388             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7389      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7390 cd            derx(lll,kkk,iii)=0.0d0
7391           enddo
7392         enddo
7393       enddo
7394 cd      gcorr_loc(l-1)=0.0d0
7395 cd      gcorr_loc(j-1)=0.0d0
7396 cd      gcorr_loc(k-1)=0.0d0
7397 cd      eel4=1.0d0
7398 cd      write (iout,*)'Contacts have occurred for peptide groups',
7399 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7400 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7401       if (j.lt.nres-1) then
7402         j1=j+1
7403         j2=j-1
7404       else
7405         j1=j-1
7406         j2=j-2
7407       endif
7408       if (l.lt.nres-1) then
7409         l1=l+1
7410         l2=l-1
7411       else
7412         l1=l-1
7413         l2=l-2
7414       endif
7415       do ll=1,3
7416 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7417 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7418         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7419         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7420 cgrad        ghalf=0.5d0*ggg1(ll)
7421         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7422         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7423         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7424         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7425         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7426         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7427 cgrad        ghalf=0.5d0*ggg2(ll)
7428         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7429         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7430         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7431         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7432         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7433         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7434       enddo
7435 cgrad      do m=i+1,j-1
7436 cgrad        do ll=1,3
7437 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7438 cgrad        enddo
7439 cgrad      enddo
7440 cgrad      do m=k+1,l-1
7441 cgrad        do ll=1,3
7442 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7443 cgrad        enddo
7444 cgrad      enddo
7445 cgrad      do m=i+2,j2
7446 cgrad        do ll=1,3
7447 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7448 cgrad        enddo
7449 cgrad      enddo
7450 cgrad      do m=k+2,l2
7451 cgrad        do ll=1,3
7452 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7453 cgrad        enddo
7454 cgrad      enddo
7455 cd      do iii=1,nres-3
7456 cd        write (2,*) iii,gcorr_loc(iii)
7457 cd      enddo
7458       eello4=ekont*eel4
7459 cd      write (2,*) 'ekont',ekont
7460 cd      write (iout,*) 'eello4',ekont*eel4
7461       return
7462       end
7463 C---------------------------------------------------------------------------
7464       double precision function eello5(i,j,k,l,jj,kk)
7465       implicit real*8 (a-h,o-z)
7466       include 'DIMENSIONS'
7467       include 'COMMON.IOUNITS'
7468       include 'COMMON.CHAIN'
7469       include 'COMMON.DERIV'
7470       include 'COMMON.INTERACT'
7471       include 'COMMON.CONTACTS'
7472       include 'COMMON.TORSION'
7473       include 'COMMON.VAR'
7474       include 'COMMON.GEO'
7475       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7476       double precision ggg1(3),ggg2(3)
7477 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7478 C                                                                              C
7479 C                            Parallel chains                                   C
7480 C                                                                              C
7481 C          o             o                   o             o                   C
7482 C         /l\           / \             \   / \           / \   /              C
7483 C        /   \         /   \             \ /   \         /   \ /               C
7484 C       j| o |l1       | o |              o| o |         | o |o                C
7485 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7486 C      \i/   \         /   \ /             /   \         /   \                 C
7487 C       o    k1             o                                                  C
7488 C         (I)          (II)                (III)          (IV)                 C
7489 C                                                                              C
7490 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7491 C                                                                              C
7492 C                            Antiparallel chains                               C
7493 C                                                                              C
7494 C          o             o                   o             o                   C
7495 C         /j\           / \             \   / \           / \   /              C
7496 C        /   \         /   \             \ /   \         /   \ /               C
7497 C      j1| o |l        | o |              o| o |         | o |o                C
7498 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7499 C      \i/   \         /   \ /             /   \         /   \                 C
7500 C       o     k1            o                                                  C
7501 C         (I)          (II)                (III)          (IV)                 C
7502 C                                                                              C
7503 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7504 C                                                                              C
7505 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7506 C                                                                              C
7507 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7508 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7509 cd        eello5=0.0d0
7510 cd        return
7511 cd      endif
7512 cd      write (iout,*)
7513 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7514 cd     &   ' and',k,l
7515       itk=itortyp(itype(k))
7516       itl=itortyp(itype(l))
7517       itj=itortyp(itype(j))
7518       eello5_1=0.0d0
7519       eello5_2=0.0d0
7520       eello5_3=0.0d0
7521       eello5_4=0.0d0
7522 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7523 cd     &   eel5_3_num,eel5_4_num)
7524       do iii=1,2
7525         do kkk=1,5
7526           do lll=1,3
7527             derx(lll,kkk,iii)=0.0d0
7528           enddo
7529         enddo
7530       enddo
7531 cd      eij=facont_hb(jj,i)
7532 cd      ekl=facont_hb(kk,k)
7533 cd      ekont=eij*ekl
7534 cd      write (iout,*)'Contacts have occurred for peptide groups',
7535 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7536 cd      goto 1111
7537 C Contribution from the graph I.
7538 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7539 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7540       call transpose2(EUg(1,1,k),auxmat(1,1))
7541       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7542       vv(1)=pizda(1,1)-pizda(2,2)
7543       vv(2)=pizda(1,2)+pizda(2,1)
7544       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7545      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7546 C Explicit gradient in virtual-dihedral angles.
7547       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7548      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7549      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7550       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7551       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7552       vv(1)=pizda(1,1)-pizda(2,2)
7553       vv(2)=pizda(1,2)+pizda(2,1)
7554       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7555      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7556      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7557       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7558       vv(1)=pizda(1,1)-pizda(2,2)
7559       vv(2)=pizda(1,2)+pizda(2,1)
7560       if (l.eq.j+1) then
7561         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7562      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7563      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7564       else
7565         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7566      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7567      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7568       endif
7569 C Cartesian gradient
7570       do iii=1,2
7571         do kkk=1,5
7572           do lll=1,3
7573             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7574      &        pizda(1,1))
7575             vv(1)=pizda(1,1)-pizda(2,2)
7576             vv(2)=pizda(1,2)+pizda(2,1)
7577             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7578      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7579      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7580           enddo
7581         enddo
7582       enddo
7583 c      goto 1112
7584 c1111  continue
7585 C Contribution from graph II
7586       call transpose2(EE(1,1,itk),auxmat(1,1))
7587       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7588       vv(1)=pizda(1,1)+pizda(2,2)
7589       vv(2)=pizda(2,1)-pizda(1,2)
7590       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7591      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7592 C Explicit gradient in virtual-dihedral angles.
7593       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7594      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7595       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7596       vv(1)=pizda(1,1)+pizda(2,2)
7597       vv(2)=pizda(2,1)-pizda(1,2)
7598       if (l.eq.j+1) then
7599         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7600      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7601      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7602       else
7603         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7604      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7605      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7606       endif
7607 C Cartesian gradient
7608       do iii=1,2
7609         do kkk=1,5
7610           do lll=1,3
7611             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7612      &        pizda(1,1))
7613             vv(1)=pizda(1,1)+pizda(2,2)
7614             vv(2)=pizda(2,1)-pizda(1,2)
7615             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7616      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7617      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7618           enddo
7619         enddo
7620       enddo
7621 cd      goto 1112
7622 cd1111  continue
7623       if (l.eq.j+1) then
7624 cd        goto 1110
7625 C Parallel orientation
7626 C Contribution from graph III
7627         call transpose2(EUg(1,1,l),auxmat(1,1))
7628         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7629         vv(1)=pizda(1,1)-pizda(2,2)
7630         vv(2)=pizda(1,2)+pizda(2,1)
7631         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7632      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7633 C Explicit gradient in virtual-dihedral angles.
7634         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7635      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7636      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7637         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7638         vv(1)=pizda(1,1)-pizda(2,2)
7639         vv(2)=pizda(1,2)+pizda(2,1)
7640         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7641      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7642      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7643         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7644         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7645         vv(1)=pizda(1,1)-pizda(2,2)
7646         vv(2)=pizda(1,2)+pizda(2,1)
7647         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7648      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7649      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7650 C Cartesian gradient
7651         do iii=1,2
7652           do kkk=1,5
7653             do lll=1,3
7654               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7655      &          pizda(1,1))
7656               vv(1)=pizda(1,1)-pizda(2,2)
7657               vv(2)=pizda(1,2)+pizda(2,1)
7658               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7659      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7660      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7661             enddo
7662           enddo
7663         enddo
7664 cd        goto 1112
7665 C Contribution from graph IV
7666 cd1110    continue
7667         call transpose2(EE(1,1,itl),auxmat(1,1))
7668         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7669         vv(1)=pizda(1,1)+pizda(2,2)
7670         vv(2)=pizda(2,1)-pizda(1,2)
7671         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7672      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7673 C Explicit gradient in virtual-dihedral angles.
7674         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7675      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7676         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7677         vv(1)=pizda(1,1)+pizda(2,2)
7678         vv(2)=pizda(2,1)-pizda(1,2)
7679         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7680      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7681      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7682 C Cartesian gradient
7683         do iii=1,2
7684           do kkk=1,5
7685             do lll=1,3
7686               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7687      &          pizda(1,1))
7688               vv(1)=pizda(1,1)+pizda(2,2)
7689               vv(2)=pizda(2,1)-pizda(1,2)
7690               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7691      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7692      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7693             enddo
7694           enddo
7695         enddo
7696       else
7697 C Antiparallel orientation
7698 C Contribution from graph III
7699 c        goto 1110
7700         call transpose2(EUg(1,1,j),auxmat(1,1))
7701         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7702         vv(1)=pizda(1,1)-pizda(2,2)
7703         vv(2)=pizda(1,2)+pizda(2,1)
7704         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7705      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7706 C Explicit gradient in virtual-dihedral angles.
7707         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7708      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7709      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7710         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7711         vv(1)=pizda(1,1)-pizda(2,2)
7712         vv(2)=pizda(1,2)+pizda(2,1)
7713         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7714      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7715      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7716         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7717         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7718         vv(1)=pizda(1,1)-pizda(2,2)
7719         vv(2)=pizda(1,2)+pizda(2,1)
7720         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7721      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7722      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7723 C Cartesian gradient
7724         do iii=1,2
7725           do kkk=1,5
7726             do lll=1,3
7727               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7728      &          pizda(1,1))
7729               vv(1)=pizda(1,1)-pizda(2,2)
7730               vv(2)=pizda(1,2)+pizda(2,1)
7731               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7732      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7733      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7734             enddo
7735           enddo
7736         enddo
7737 cd        goto 1112
7738 C Contribution from graph IV
7739 1110    continue
7740         call transpose2(EE(1,1,itj),auxmat(1,1))
7741         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7742         vv(1)=pizda(1,1)+pizda(2,2)
7743         vv(2)=pizda(2,1)-pizda(1,2)
7744         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7745      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7746 C Explicit gradient in virtual-dihedral angles.
7747         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7748      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7749         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7750         vv(1)=pizda(1,1)+pizda(2,2)
7751         vv(2)=pizda(2,1)-pizda(1,2)
7752         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7753      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7754      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7755 C Cartesian gradient
7756         do iii=1,2
7757           do kkk=1,5
7758             do lll=1,3
7759               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7760      &          pizda(1,1))
7761               vv(1)=pizda(1,1)+pizda(2,2)
7762               vv(2)=pizda(2,1)-pizda(1,2)
7763               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7764      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7765      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7766             enddo
7767           enddo
7768         enddo
7769       endif
7770 1112  continue
7771       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7772 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7773 cd        write (2,*) 'ijkl',i,j,k,l
7774 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7775 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7776 cd      endif
7777 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7778 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7779 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7780 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7781       if (j.lt.nres-1) then
7782         j1=j+1
7783         j2=j-1
7784       else
7785         j1=j-1
7786         j2=j-2
7787       endif
7788       if (l.lt.nres-1) then
7789         l1=l+1
7790         l2=l-1
7791       else
7792         l1=l-1
7793         l2=l-2
7794       endif
7795 cd      eij=1.0d0
7796 cd      ekl=1.0d0
7797 cd      ekont=1.0d0
7798 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7799 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7800 C        summed up outside the subrouine as for the other subroutines
7801 C        handling long-range interactions. The old code is commented out
7802 C        with "cgrad" to keep track of changes.
7803       do ll=1,3
7804 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7805 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7806         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7807         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7808 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7809 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7810 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7811 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7812 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7813 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7814 c     &   gradcorr5ij,
7815 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7816 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7817 cgrad        ghalf=0.5d0*ggg1(ll)
7818 cd        ghalf=0.0d0
7819         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7820         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7821         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7822         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7823         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7824         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7825 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7826 cgrad        ghalf=0.5d0*ggg2(ll)
7827 cd        ghalf=0.0d0
7828         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7829         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7830         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7831         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7832         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7833         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7834       enddo
7835 cd      goto 1112
7836 cgrad      do m=i+1,j-1
7837 cgrad        do ll=1,3
7838 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7839 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7840 cgrad        enddo
7841 cgrad      enddo
7842 cgrad      do m=k+1,l-1
7843 cgrad        do ll=1,3
7844 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7845 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7846 cgrad        enddo
7847 cgrad      enddo
7848 c1112  continue
7849 cgrad      do m=i+2,j2
7850 cgrad        do ll=1,3
7851 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7852 cgrad        enddo
7853 cgrad      enddo
7854 cgrad      do m=k+2,l2
7855 cgrad        do ll=1,3
7856 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7857 cgrad        enddo
7858 cgrad      enddo
7859 cd      do iii=1,nres-3
7860 cd        write (2,*) iii,g_corr5_loc(iii)
7861 cd      enddo
7862       eello5=ekont*eel5
7863 cd      write (2,*) 'ekont',ekont
7864 cd      write (iout,*) 'eello5',ekont*eel5
7865       return
7866       end
7867 c--------------------------------------------------------------------------
7868       double precision function eello6(i,j,k,l,jj,kk)
7869       implicit real*8 (a-h,o-z)
7870       include 'DIMENSIONS'
7871       include 'COMMON.IOUNITS'
7872       include 'COMMON.CHAIN'
7873       include 'COMMON.DERIV'
7874       include 'COMMON.INTERACT'
7875       include 'COMMON.CONTACTS'
7876       include 'COMMON.TORSION'
7877       include 'COMMON.VAR'
7878       include 'COMMON.GEO'
7879       include 'COMMON.FFIELD'
7880       double precision ggg1(3),ggg2(3)
7881 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7882 cd        eello6=0.0d0
7883 cd        return
7884 cd      endif
7885 cd      write (iout,*)
7886 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7887 cd     &   ' and',k,l
7888       eello6_1=0.0d0
7889       eello6_2=0.0d0
7890       eello6_3=0.0d0
7891       eello6_4=0.0d0
7892       eello6_5=0.0d0
7893       eello6_6=0.0d0
7894 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7895 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7896       do iii=1,2
7897         do kkk=1,5
7898           do lll=1,3
7899             derx(lll,kkk,iii)=0.0d0
7900           enddo
7901         enddo
7902       enddo
7903 cd      eij=facont_hb(jj,i)
7904 cd      ekl=facont_hb(kk,k)
7905 cd      ekont=eij*ekl
7906 cd      eij=1.0d0
7907 cd      ekl=1.0d0
7908 cd      ekont=1.0d0
7909       if (l.eq.j+1) then
7910         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7911         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7912         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7913         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7914         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7915         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7916       else
7917         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7918         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7919         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7920         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7921         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7922           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7923         else
7924           eello6_5=0.0d0
7925         endif
7926         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7927       endif
7928 C If turn contributions are considered, they will be handled separately.
7929       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7930 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7931 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7932 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7933 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7934 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7935 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7936 cd      goto 1112
7937       if (j.lt.nres-1) then
7938         j1=j+1
7939         j2=j-1
7940       else
7941         j1=j-1
7942         j2=j-2
7943       endif
7944       if (l.lt.nres-1) then
7945         l1=l+1
7946         l2=l-1
7947       else
7948         l1=l-1
7949         l2=l-2
7950       endif
7951       do ll=1,3
7952 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7953 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7954 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7955 cgrad        ghalf=0.5d0*ggg1(ll)
7956 cd        ghalf=0.0d0
7957         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7958         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7959         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7960         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7961         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7962         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7963         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7964         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7965 cgrad        ghalf=0.5d0*ggg2(ll)
7966 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7967 cd        ghalf=0.0d0
7968         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7969         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7970         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7971         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7972         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7973         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7974       enddo
7975 cd      goto 1112
7976 cgrad      do m=i+1,j-1
7977 cgrad        do ll=1,3
7978 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7979 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7980 cgrad        enddo
7981 cgrad      enddo
7982 cgrad      do m=k+1,l-1
7983 cgrad        do ll=1,3
7984 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7985 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7986 cgrad        enddo
7987 cgrad      enddo
7988 cgrad1112  continue
7989 cgrad      do m=i+2,j2
7990 cgrad        do ll=1,3
7991 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7992 cgrad        enddo
7993 cgrad      enddo
7994 cgrad      do m=k+2,l2
7995 cgrad        do ll=1,3
7996 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7997 cgrad        enddo
7998 cgrad      enddo
7999 cd      do iii=1,nres-3
8000 cd        write (2,*) iii,g_corr6_loc(iii)
8001 cd      enddo
8002       eello6=ekont*eel6
8003 cd      write (2,*) 'ekont',ekont
8004 cd      write (iout,*) 'eello6',ekont*eel6
8005       return
8006       end
8007 c--------------------------------------------------------------------------
8008       double precision function eello6_graph1(i,j,k,l,imat,swap)
8009       implicit real*8 (a-h,o-z)
8010       include 'DIMENSIONS'
8011       include 'COMMON.IOUNITS'
8012       include 'COMMON.CHAIN'
8013       include 'COMMON.DERIV'
8014       include 'COMMON.INTERACT'
8015       include 'COMMON.CONTACTS'
8016       include 'COMMON.TORSION'
8017       include 'COMMON.VAR'
8018       include 'COMMON.GEO'
8019       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8020       logical swap
8021       logical lprn
8022       common /kutas/ lprn
8023 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8024 C
8025 C      Parallel       Antiparallel
8026 C
8027 C          o             o
8028 C         /l\           /j\
8029 C        /   \         /   \
8030 C       /| o |         | o |\
8031 C     \ j|/k\|  /   \  |/k\|l /
8032 C      \ /   \ /     \ /   \ /
8033 C       o     o       o     o
8034 C       i             i
8035 C
8036 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8037       itk=itortyp(itype(k))
8038       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8039       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8040       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8041       call transpose2(EUgC(1,1,k),auxmat(1,1))
8042       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8043       vv1(1)=pizda1(1,1)-pizda1(2,2)
8044       vv1(2)=pizda1(1,2)+pizda1(2,1)
8045       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8046       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8047       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8048       s5=scalar2(vv(1),Dtobr2(1,i))
8049 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8050       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8051       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8052      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8053      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8054      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8055      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8056      & +scalar2(vv(1),Dtobr2der(1,i)))
8057       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8058       vv1(1)=pizda1(1,1)-pizda1(2,2)
8059       vv1(2)=pizda1(1,2)+pizda1(2,1)
8060       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8061       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8062       if (l.eq.j+1) then
8063         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8064      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8065      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8066      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8067      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8068       else
8069         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8070      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8071      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8072      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8073      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8074       endif
8075       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8076       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8077       vv1(1)=pizda1(1,1)-pizda1(2,2)
8078       vv1(2)=pizda1(1,2)+pizda1(2,1)
8079       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8080      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8081      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8082      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8083       do iii=1,2
8084         if (swap) then
8085           ind=3-iii
8086         else
8087           ind=iii
8088         endif
8089         do kkk=1,5
8090           do lll=1,3
8091             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8092             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8093             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8094             call transpose2(EUgC(1,1,k),auxmat(1,1))
8095             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8096      &        pizda1(1,1))
8097             vv1(1)=pizda1(1,1)-pizda1(2,2)
8098             vv1(2)=pizda1(1,2)+pizda1(2,1)
8099             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8100             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8101      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8102             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8103      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8104             s5=scalar2(vv(1),Dtobr2(1,i))
8105             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8106           enddo
8107         enddo
8108       enddo
8109       return
8110       end
8111 c----------------------------------------------------------------------------
8112       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8113       implicit real*8 (a-h,o-z)
8114       include 'DIMENSIONS'
8115       include 'COMMON.IOUNITS'
8116       include 'COMMON.CHAIN'
8117       include 'COMMON.DERIV'
8118       include 'COMMON.INTERACT'
8119       include 'COMMON.CONTACTS'
8120       include 'COMMON.TORSION'
8121       include 'COMMON.VAR'
8122       include 'COMMON.GEO'
8123       logical swap
8124       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8125      & auxvec1(2),auxvec2(1),auxmat1(2,2)
8126       logical lprn
8127       common /kutas/ lprn
8128 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8129 C
8130 C      Parallel       Antiparallel
8131 C
8132 C          o             o
8133 C     \   /l\           /j\   /
8134 C      \ /   \         /   \ /
8135 C       o| o |         | o |o
8136 C     \ j|/k\|      \  |/k\|l
8137 C      \ /   \       \ /   \
8138 C       o             o
8139 C       i             i
8140 C
8141 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8142 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8143 C AL 7/4/01 s1 would occur in the sixth-order moment,
8144 C           but not in a cluster cumulant
8145 #ifdef MOMENT
8146       s1=dip(1,jj,i)*dip(1,kk,k)
8147 #endif
8148       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8149       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8150       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8151       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8152       call transpose2(EUg(1,1,k),auxmat(1,1))
8153       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8154       vv(1)=pizda(1,1)-pizda(2,2)
8155       vv(2)=pizda(1,2)+pizda(2,1)
8156       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8157 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8158 #ifdef MOMENT
8159       eello6_graph2=-(s1+s2+s3+s4)
8160 #else
8161       eello6_graph2=-(s2+s3+s4)
8162 #endif
8163 c      eello6_graph2=-s3
8164 C Derivatives in gamma(i-1)
8165       if (i.gt.1) then
8166 #ifdef MOMENT
8167         s1=dipderg(1,jj,i)*dip(1,kk,k)
8168 #endif
8169         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8170         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8171         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8172         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8173 #ifdef MOMENT
8174         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8175 #else
8176         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8177 #endif
8178 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8179       endif
8180 C Derivatives in gamma(k-1)
8181 #ifdef MOMENT
8182       s1=dip(1,jj,i)*dipderg(1,kk,k)
8183 #endif
8184       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8185       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8186       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8187       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8188       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8189       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8190       vv(1)=pizda(1,1)-pizda(2,2)
8191       vv(2)=pizda(1,2)+pizda(2,1)
8192       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8193 #ifdef MOMENT
8194       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8195 #else
8196       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8197 #endif
8198 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8199 C Derivatives in gamma(j-1) or gamma(l-1)
8200       if (j.gt.1) then
8201 #ifdef MOMENT
8202         s1=dipderg(3,jj,i)*dip(1,kk,k)
8203 #endif
8204         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8205         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8206         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8207         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8208         vv(1)=pizda(1,1)-pizda(2,2)
8209         vv(2)=pizda(1,2)+pizda(2,1)
8210         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8211 #ifdef MOMENT
8212         if (swap) then
8213           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8214         else
8215           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8216         endif
8217 #endif
8218         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8219 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8220       endif
8221 C Derivatives in gamma(l-1) or gamma(j-1)
8222       if (l.gt.1) then
8223 #ifdef MOMENT
8224         s1=dip(1,jj,i)*dipderg(3,kk,k)
8225 #endif
8226         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8227         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8228         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8229         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8230         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8231         vv(1)=pizda(1,1)-pizda(2,2)
8232         vv(2)=pizda(1,2)+pizda(2,1)
8233         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8234 #ifdef MOMENT
8235         if (swap) then
8236           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8237         else
8238           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8239         endif
8240 #endif
8241         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8242 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8243       endif
8244 C Cartesian derivatives.
8245       if (lprn) then
8246         write (2,*) 'In eello6_graph2'
8247         do iii=1,2
8248           write (2,*) 'iii=',iii
8249           do kkk=1,5
8250             write (2,*) 'kkk=',kkk
8251             do jjj=1,2
8252               write (2,'(3(2f10.5),5x)')
8253      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8254             enddo
8255           enddo
8256         enddo
8257       endif
8258       do iii=1,2
8259         do kkk=1,5
8260           do lll=1,3
8261 #ifdef MOMENT
8262             if (iii.eq.1) then
8263               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8264             else
8265               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8266             endif
8267 #endif
8268             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8269      &        auxvec(1))
8270             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8271             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8272      &        auxvec(1))
8273             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8274             call transpose2(EUg(1,1,k),auxmat(1,1))
8275             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8276      &        pizda(1,1))
8277             vv(1)=pizda(1,1)-pizda(2,2)
8278             vv(2)=pizda(1,2)+pizda(2,1)
8279             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8280 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8281 #ifdef MOMENT
8282             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8283 #else
8284             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8285 #endif
8286             if (swap) then
8287               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8288             else
8289               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8290             endif
8291           enddo
8292         enddo
8293       enddo
8294       return
8295       end
8296 c----------------------------------------------------------------------------
8297       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8298       implicit real*8 (a-h,o-z)
8299       include 'DIMENSIONS'
8300       include 'COMMON.IOUNITS'
8301       include 'COMMON.CHAIN'
8302       include 'COMMON.DERIV'
8303       include 'COMMON.INTERACT'
8304       include 'COMMON.CONTACTS'
8305       include 'COMMON.TORSION'
8306       include 'COMMON.VAR'
8307       include 'COMMON.GEO'
8308       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8309       logical swap
8310 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8311 C
8312 C      Parallel       Antiparallel
8313 C
8314 C          o             o
8315 C         /l\   /   \   /j\
8316 C        /   \ /     \ /   \
8317 C       /| o |o       o| o |\
8318 C       j|/k\|  /      |/k\|l /
8319 C        /   \ /       /   \ /
8320 C       /     o       /     o
8321 C       i             i
8322 C
8323 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8324 C
8325 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8326 C           energy moment and not to the cluster cumulant.
8327       iti=itortyp(itype(i))
8328       if (j.lt.nres-1) then
8329         itj1=itortyp(itype(j+1))
8330       else
8331         itj1=ntortyp+1
8332       endif
8333       itk=itortyp(itype(k))
8334       itk1=itortyp(itype(k+1))
8335       if (l.lt.nres-1) then
8336         itl1=itortyp(itype(l+1))
8337       else
8338         itl1=ntortyp+1
8339       endif
8340 #ifdef MOMENT
8341       s1=dip(4,jj,i)*dip(4,kk,k)
8342 #endif
8343       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8344       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8345       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8346       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8347       call transpose2(EE(1,1,itk),auxmat(1,1))
8348       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8349       vv(1)=pizda(1,1)+pizda(2,2)
8350       vv(2)=pizda(2,1)-pizda(1,2)
8351       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8352 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8353 cd     & "sum",-(s2+s3+s4)
8354 #ifdef MOMENT
8355       eello6_graph3=-(s1+s2+s3+s4)
8356 #else
8357       eello6_graph3=-(s2+s3+s4)
8358 #endif
8359 c      eello6_graph3=-s4
8360 C Derivatives in gamma(k-1)
8361       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8362       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8363       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8364       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8365 C Derivatives in gamma(l-1)
8366       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8367       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8368       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8369       vv(1)=pizda(1,1)+pizda(2,2)
8370       vv(2)=pizda(2,1)-pizda(1,2)
8371       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8372       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8373 C Cartesian derivatives.
8374       do iii=1,2
8375         do kkk=1,5
8376           do lll=1,3
8377 #ifdef MOMENT
8378             if (iii.eq.1) then
8379               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8380             else
8381               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8382             endif
8383 #endif
8384             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8385      &        auxvec(1))
8386             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8387             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8388      &        auxvec(1))
8389             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8390             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8391      &        pizda(1,1))
8392             vv(1)=pizda(1,1)+pizda(2,2)
8393             vv(2)=pizda(2,1)-pizda(1,2)
8394             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8395 #ifdef MOMENT
8396             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8397 #else
8398             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8399 #endif
8400             if (swap) then
8401               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8402             else
8403               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8404             endif
8405 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8406           enddo
8407         enddo
8408       enddo
8409       return
8410       end
8411 c----------------------------------------------------------------------------
8412       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8413       implicit real*8 (a-h,o-z)
8414       include 'DIMENSIONS'
8415       include 'COMMON.IOUNITS'
8416       include 'COMMON.CHAIN'
8417       include 'COMMON.DERIV'
8418       include 'COMMON.INTERACT'
8419       include 'COMMON.CONTACTS'
8420       include 'COMMON.TORSION'
8421       include 'COMMON.VAR'
8422       include 'COMMON.GEO'
8423       include 'COMMON.FFIELD'
8424       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8425      & auxvec1(2),auxmat1(2,2)
8426       logical swap
8427 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8428 C
8429 C      Parallel       Antiparallel
8430 C
8431 C          o             o
8432 C         /l\   /   \   /j\
8433 C        /   \ /     \ /   \
8434 C       /| o |o       o| o |\
8435 C     \ j|/k\|      \  |/k\|l
8436 C      \ /   \       \ /   \
8437 C       o     \       o     \
8438 C       i             i
8439 C
8440 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8441 C
8442 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8443 C           energy moment and not to the cluster cumulant.
8444 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8445       iti=itortyp(itype(i))
8446       itj=itortyp(itype(j))
8447       if (j.lt.nres-1) then
8448         itj1=itortyp(itype(j+1))
8449       else
8450         itj1=ntortyp+1
8451       endif
8452       itk=itortyp(itype(k))
8453       if (k.lt.nres-1) then
8454         itk1=itortyp(itype(k+1))
8455       else
8456         itk1=ntortyp+1
8457       endif
8458       itl=itortyp(itype(l))
8459       if (l.lt.nres-1) then
8460         itl1=itortyp(itype(l+1))
8461       else
8462         itl1=ntortyp+1
8463       endif
8464 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8465 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8466 cd     & ' itl',itl,' itl1',itl1
8467 #ifdef MOMENT
8468       if (imat.eq.1) then
8469         s1=dip(3,jj,i)*dip(3,kk,k)
8470       else
8471         s1=dip(2,jj,j)*dip(2,kk,l)
8472       endif
8473 #endif
8474       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8475       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8476       if (j.eq.l+1) then
8477         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8478         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8479       else
8480         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8481         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8482       endif
8483       call transpose2(EUg(1,1,k),auxmat(1,1))
8484       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8485       vv(1)=pizda(1,1)-pizda(2,2)
8486       vv(2)=pizda(2,1)+pizda(1,2)
8487       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8488 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8489 #ifdef MOMENT
8490       eello6_graph4=-(s1+s2+s3+s4)
8491 #else
8492       eello6_graph4=-(s2+s3+s4)
8493 #endif
8494 C Derivatives in gamma(i-1)
8495       if (i.gt.1) then
8496 #ifdef MOMENT
8497         if (imat.eq.1) then
8498           s1=dipderg(2,jj,i)*dip(3,kk,k)
8499         else
8500           s1=dipderg(4,jj,j)*dip(2,kk,l)
8501         endif
8502 #endif
8503         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8504         if (j.eq.l+1) then
8505           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8506           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8507         else
8508           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8509           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8510         endif
8511         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8512         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8513 cd          write (2,*) 'turn6 derivatives'
8514 #ifdef MOMENT
8515           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8516 #else
8517           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8518 #endif
8519         else
8520 #ifdef MOMENT
8521           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8522 #else
8523           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8524 #endif
8525         endif
8526       endif
8527 C Derivatives in gamma(k-1)
8528 #ifdef MOMENT
8529       if (imat.eq.1) then
8530         s1=dip(3,jj,i)*dipderg(2,kk,k)
8531       else
8532         s1=dip(2,jj,j)*dipderg(4,kk,l)
8533       endif
8534 #endif
8535       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8536       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8537       if (j.eq.l+1) then
8538         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8539         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8540       else
8541         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8542         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8543       endif
8544       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8545       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8546       vv(1)=pizda(1,1)-pizda(2,2)
8547       vv(2)=pizda(2,1)+pizda(1,2)
8548       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8549       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8550 #ifdef MOMENT
8551         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8552 #else
8553         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8554 #endif
8555       else
8556 #ifdef MOMENT
8557         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8558 #else
8559         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8560 #endif
8561       endif
8562 C Derivatives in gamma(j-1) or gamma(l-1)
8563       if (l.eq.j+1 .and. l.gt.1) then
8564         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8565         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8566         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8567         vv(1)=pizda(1,1)-pizda(2,2)
8568         vv(2)=pizda(2,1)+pizda(1,2)
8569         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8570         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8571       else if (j.gt.1) then
8572         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8573         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8574         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8575         vv(1)=pizda(1,1)-pizda(2,2)
8576         vv(2)=pizda(2,1)+pizda(1,2)
8577         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8578         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8579           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8580         else
8581           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8582         endif
8583       endif
8584 C Cartesian derivatives.
8585       do iii=1,2
8586         do kkk=1,5
8587           do lll=1,3
8588 #ifdef MOMENT
8589             if (iii.eq.1) then
8590               if (imat.eq.1) then
8591                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8592               else
8593                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8594               endif
8595             else
8596               if (imat.eq.1) then
8597                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8598               else
8599                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8600               endif
8601             endif
8602 #endif
8603             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8604      &        auxvec(1))
8605             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8606             if (j.eq.l+1) then
8607               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8608      &          b1(1,itj1),auxvec(1))
8609               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8610             else
8611               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8612      &          b1(1,itl1),auxvec(1))
8613               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8614             endif
8615             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8616      &        pizda(1,1))
8617             vv(1)=pizda(1,1)-pizda(2,2)
8618             vv(2)=pizda(2,1)+pizda(1,2)
8619             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8620             if (swap) then
8621               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8622 #ifdef MOMENT
8623                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8624      &             -(s1+s2+s4)
8625 #else
8626                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8627      &             -(s2+s4)
8628 #endif
8629                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8630               else
8631 #ifdef MOMENT
8632                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8633 #else
8634                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8635 #endif
8636                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8637               endif
8638             else
8639 #ifdef MOMENT
8640               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8641 #else
8642               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8643 #endif
8644               if (l.eq.j+1) then
8645                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8646               else
8647                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8648               endif
8649             endif
8650           enddo
8651         enddo
8652       enddo
8653       return
8654       end
8655 c----------------------------------------------------------------------------
8656       double precision function eello_turn6(i,jj,kk)
8657       implicit real*8 (a-h,o-z)
8658       include 'DIMENSIONS'
8659       include 'COMMON.IOUNITS'
8660       include 'COMMON.CHAIN'
8661       include 'COMMON.DERIV'
8662       include 'COMMON.INTERACT'
8663       include 'COMMON.CONTACTS'
8664       include 'COMMON.TORSION'
8665       include 'COMMON.VAR'
8666       include 'COMMON.GEO'
8667       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8668      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8669      &  ggg1(3),ggg2(3)
8670       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8671      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8672 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8673 C           the respective energy moment and not to the cluster cumulant.
8674       s1=0.0d0
8675       s8=0.0d0
8676       s13=0.0d0
8677 c
8678       eello_turn6=0.0d0
8679       j=i+4
8680       k=i+1
8681       l=i+3
8682       iti=itortyp(itype(i))
8683       itk=itortyp(itype(k))
8684       itk1=itortyp(itype(k+1))
8685       itl=itortyp(itype(l))
8686       itj=itortyp(itype(j))
8687 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8688 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8689 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8690 cd        eello6=0.0d0
8691 cd        return
8692 cd      endif
8693 cd      write (iout,*)
8694 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8695 cd     &   ' and',k,l
8696 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8697       do iii=1,2
8698         do kkk=1,5
8699           do lll=1,3
8700             derx_turn(lll,kkk,iii)=0.0d0
8701           enddo
8702         enddo
8703       enddo
8704 cd      eij=1.0d0
8705 cd      ekl=1.0d0
8706 cd      ekont=1.0d0
8707       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8708 cd      eello6_5=0.0d0
8709 cd      write (2,*) 'eello6_5',eello6_5
8710 #ifdef MOMENT
8711       call transpose2(AEA(1,1,1),auxmat(1,1))
8712       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8713       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8714       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8715 #endif
8716       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8717       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8718       s2 = scalar2(b1(1,itk),vtemp1(1))
8719 #ifdef MOMENT
8720       call transpose2(AEA(1,1,2),atemp(1,1))
8721       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8722       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8723       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8724 #endif
8725       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8726       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8727       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8728 #ifdef MOMENT
8729       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8730       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8731       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8732       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8733       ss13 = scalar2(b1(1,itk),vtemp4(1))
8734       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8735 #endif
8736 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8737 c      s1=0.0d0
8738 c      s2=0.0d0
8739 c      s8=0.0d0
8740 c      s12=0.0d0
8741 c      s13=0.0d0
8742       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8743 C Derivatives in gamma(i+2)
8744       s1d =0.0d0
8745       s8d =0.0d0
8746 #ifdef MOMENT
8747       call transpose2(AEA(1,1,1),auxmatd(1,1))
8748       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8749       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8750       call transpose2(AEAderg(1,1,2),atempd(1,1))
8751       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8752       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8753 #endif
8754       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8755       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8756       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8757 c      s1d=0.0d0
8758 c      s2d=0.0d0
8759 c      s8d=0.0d0
8760 c      s12d=0.0d0
8761 c      s13d=0.0d0
8762       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8763 C Derivatives in gamma(i+3)
8764 #ifdef MOMENT
8765       call transpose2(AEA(1,1,1),auxmatd(1,1))
8766       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8767       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8768       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8769 #endif
8770       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8771       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8772       s2d = scalar2(b1(1,itk),vtemp1d(1))
8773 #ifdef MOMENT
8774       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8775       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8776 #endif
8777       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8778 #ifdef MOMENT
8779       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8780       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8781       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8782 #endif
8783 c      s1d=0.0d0
8784 c      s2d=0.0d0
8785 c      s8d=0.0d0
8786 c      s12d=0.0d0
8787 c      s13d=0.0d0
8788 #ifdef MOMENT
8789       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8790      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8791 #else
8792       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8793      &               -0.5d0*ekont*(s2d+s12d)
8794 #endif
8795 C Derivatives in gamma(i+4)
8796       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8797       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8798       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8799 #ifdef MOMENT
8800       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8801       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8802       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8803 #endif
8804 c      s1d=0.0d0
8805 c      s2d=0.0d0
8806 c      s8d=0.0d0
8807 C      s12d=0.0d0
8808 c      s13d=0.0d0
8809 #ifdef MOMENT
8810       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8811 #else
8812       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8813 #endif
8814 C Derivatives in gamma(i+5)
8815 #ifdef MOMENT
8816       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8817       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8818       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8819 #endif
8820       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8821       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8822       s2d = scalar2(b1(1,itk),vtemp1d(1))
8823 #ifdef MOMENT
8824       call transpose2(AEA(1,1,2),atempd(1,1))
8825       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8826       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8827 #endif
8828       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8829       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8830 #ifdef MOMENT
8831       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8832       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8833       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8834 #endif
8835 c      s1d=0.0d0
8836 c      s2d=0.0d0
8837 c      s8d=0.0d0
8838 c      s12d=0.0d0
8839 c      s13d=0.0d0
8840 #ifdef MOMENT
8841       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8842      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8843 #else
8844       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8845      &               -0.5d0*ekont*(s2d+s12d)
8846 #endif
8847 C Cartesian derivatives
8848       do iii=1,2
8849         do kkk=1,5
8850           do lll=1,3
8851 #ifdef MOMENT
8852             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8853             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8854             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8855 #endif
8856             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8857             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8858      &          vtemp1d(1))
8859             s2d = scalar2(b1(1,itk),vtemp1d(1))
8860 #ifdef MOMENT
8861             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8862             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8863             s8d = -(atempd(1,1)+atempd(2,2))*
8864      &           scalar2(cc(1,1,itl),vtemp2(1))
8865 #endif
8866             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8867      &           auxmatd(1,1))
8868             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8869             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8870 c      s1d=0.0d0
8871 c      s2d=0.0d0
8872 c      s8d=0.0d0
8873 c      s12d=0.0d0
8874 c      s13d=0.0d0
8875 #ifdef MOMENT
8876             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8877      &        - 0.5d0*(s1d+s2d)
8878 #else
8879             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8880      &        - 0.5d0*s2d
8881 #endif
8882 #ifdef MOMENT
8883             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8884      &        - 0.5d0*(s8d+s12d)
8885 #else
8886             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8887      &        - 0.5d0*s12d
8888 #endif
8889           enddo
8890         enddo
8891       enddo
8892 #ifdef MOMENT
8893       do kkk=1,5
8894         do lll=1,3
8895           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8896      &      achuj_tempd(1,1))
8897           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8898           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8899           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8900           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8901           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8902      &      vtemp4d(1))
8903           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8904           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8905           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8906         enddo
8907       enddo
8908 #endif
8909 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8910 cd     &  16*eel_turn6_num
8911 cd      goto 1112
8912       if (j.lt.nres-1) then
8913         j1=j+1
8914         j2=j-1
8915       else
8916         j1=j-1
8917         j2=j-2
8918       endif
8919       if (l.lt.nres-1) then
8920         l1=l+1
8921         l2=l-1
8922       else
8923         l1=l-1
8924         l2=l-2
8925       endif
8926       do ll=1,3
8927 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8928 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8929 cgrad        ghalf=0.5d0*ggg1(ll)
8930 cd        ghalf=0.0d0
8931         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8932         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8933         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8934      &    +ekont*derx_turn(ll,2,1)
8935         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8936         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8937      &    +ekont*derx_turn(ll,4,1)
8938         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8939         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8940         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8941 cgrad        ghalf=0.5d0*ggg2(ll)
8942 cd        ghalf=0.0d0
8943         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8944      &    +ekont*derx_turn(ll,2,2)
8945         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8946         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8947      &    +ekont*derx_turn(ll,4,2)
8948         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8949         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8950         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8951       enddo
8952 cd      goto 1112
8953 cgrad      do m=i+1,j-1
8954 cgrad        do ll=1,3
8955 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8956 cgrad        enddo
8957 cgrad      enddo
8958 cgrad      do m=k+1,l-1
8959 cgrad        do ll=1,3
8960 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8961 cgrad        enddo
8962 cgrad      enddo
8963 cgrad1112  continue
8964 cgrad      do m=i+2,j2
8965 cgrad        do ll=1,3
8966 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8967 cgrad        enddo
8968 cgrad      enddo
8969 cgrad      do m=k+2,l2
8970 cgrad        do ll=1,3
8971 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8972 cgrad        enddo
8973 cgrad      enddo
8974 cd      do iii=1,nres-3
8975 cd        write (2,*) iii,g_corr6_loc(iii)
8976 cd      enddo
8977       eello_turn6=ekont*eel_turn6
8978 cd      write (2,*) 'ekont',ekont
8979 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8980       return
8981       end
8982
8983 C-----------------------------------------------------------------------------
8984       double precision function scalar(u,v)
8985 !DIR$ INLINEALWAYS scalar
8986 #ifndef OSF
8987 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8988 #endif
8989       implicit none
8990       double precision u(3),v(3)
8991 cd      double precision sc
8992 cd      integer i
8993 cd      sc=0.0d0
8994 cd      do i=1,3
8995 cd        sc=sc+u(i)*v(i)
8996 cd      enddo
8997 cd      scalar=sc
8998
8999       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9000       return
9001       end
9002 crc-------------------------------------------------
9003       SUBROUTINE MATVEC2(A1,V1,V2)
9004 !DIR$ INLINEALWAYS MATVEC2
9005 #ifndef OSF
9006 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9007 #endif
9008       implicit real*8 (a-h,o-z)
9009       include 'DIMENSIONS'
9010       DIMENSION A1(2,2),V1(2),V2(2)
9011 c      DO 1 I=1,2
9012 c        VI=0.0
9013 c        DO 3 K=1,2
9014 c    3     VI=VI+A1(I,K)*V1(K)
9015 c        Vaux(I)=VI
9016 c    1 CONTINUE
9017
9018       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9019       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9020
9021       v2(1)=vaux1
9022       v2(2)=vaux2
9023       END
9024 C---------------------------------------
9025       SUBROUTINE MATMAT2(A1,A2,A3)
9026 #ifndef OSF
9027 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9028 #endif
9029       implicit real*8 (a-h,o-z)
9030       include 'DIMENSIONS'
9031       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9032 c      DIMENSION AI3(2,2)
9033 c        DO  J=1,2
9034 c          A3IJ=0.0
9035 c          DO K=1,2
9036 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9037 c          enddo
9038 c          A3(I,J)=A3IJ
9039 c       enddo
9040 c      enddo
9041
9042       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9043       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9044       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9045       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9046
9047       A3(1,1)=AI3_11
9048       A3(2,1)=AI3_21
9049       A3(1,2)=AI3_12
9050       A3(2,2)=AI3_22
9051       END
9052
9053 c-------------------------------------------------------------------------
9054       double precision function scalar2(u,v)
9055 !DIR$ INLINEALWAYS scalar2
9056       implicit none
9057       double precision u(2),v(2)
9058       double precision sc
9059       integer i
9060       scalar2=u(1)*v(1)+u(2)*v(2)
9061       return
9062       end
9063
9064 C-----------------------------------------------------------------------------
9065
9066       subroutine transpose2(a,at)
9067 !DIR$ INLINEALWAYS transpose2
9068 #ifndef OSF
9069 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9070 #endif
9071       implicit none
9072       double precision a(2,2),at(2,2)
9073       at(1,1)=a(1,1)
9074       at(1,2)=a(2,1)
9075       at(2,1)=a(1,2)
9076       at(2,2)=a(2,2)
9077       return
9078       end
9079 c--------------------------------------------------------------------------
9080       subroutine transpose(n,a,at)
9081       implicit none
9082       integer n,i,j
9083       double precision a(n,n),at(n,n)
9084       do i=1,n
9085         do j=1,n
9086           at(j,i)=a(i,j)
9087         enddo
9088       enddo
9089       return
9090       end
9091 C---------------------------------------------------------------------------
9092       subroutine prodmat3(a1,a2,kk,transp,prod)
9093 !DIR$ INLINEALWAYS prodmat3
9094 #ifndef OSF
9095 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9096 #endif
9097       implicit none
9098       integer i,j
9099       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9100       logical transp
9101 crc      double precision auxmat(2,2),prod_(2,2)
9102
9103       if (transp) then
9104 crc        call transpose2(kk(1,1),auxmat(1,1))
9105 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9106 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9107
9108            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9109      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9110            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9111      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9112            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9113      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9114            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9115      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9116
9117       else
9118 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9119 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9120
9121            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9122      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9123            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9124      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9125            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9126      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9127            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9128      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9129
9130       endif
9131 c      call transpose2(a2(1,1),a2t(1,1))
9132
9133 crc      print *,transp
9134 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9135 crc      print *,((prod(i,j),i=1,2),j=1,2)
9136
9137       return
9138       end
9139