source/unres/src_MD/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31 #ifdef MPI
  32         time00=MPI_Wtime()
  33 #else
  34         time00=tcpu()
  35 #endif
  36 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  37         if (fg_rank.eq.0) then
  38           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  39 c          print *,"Processor",myrank," BROADCAST iorder"
  40 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  41 C FG slaves as WEIGHTS array.
  42           weights_(1)=wsc
  43           weights_(2)=wscp
  44           weights_(3)=welec
  45           weights_(4)=wcorr
  46           weights_(5)=wcorr5
  47           weights_(6)=wcorr6
  48           weights_(7)=wel_loc
  49           weights_(8)=wturn3
  50           weights_(9)=wturn4
  51           weights_(10)=wturn6
  52           weights_(11)=wang
  53           weights_(12)=wscloc
  54           weights_(13)=wtor
  55           weights_(14)=wtor_d
  56           weights_(15)=wstrain
  57           weights_(16)=wvdwpp
  58           weights_(17)=wbond
  59           weights_(18)=scal14
  60           weights_(21)=wsccor
  61           weights_(22)=wsct
  62 C FG Master broadcasts the WEIGHTS_ array
  63           call MPI_Bcast(weights_(1),n_ene,
  64      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  65         else
  66 C FG slaves receive the WEIGHTS array
  67           call MPI_Bcast(weights(1),n_ene,
  68      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  69           wsc=weights(1)
  70           wscp=weights(2)
  71           welec=weights(3)
  72           wcorr=weights(4)
  73           wcorr5=weights(5)
  74           wcorr6=weights(6)
  75           wel_loc=weights(7)
  76           wturn3=weights(8)
  77           wturn4=weights(9)
  78           wturn6=weights(10)
  79           wang=weights(11)
  80           wscloc=weights(12)
  81           wtor=weights(13)
  82           wtor_d=weights(14)
  83           wstrain=weights(15)
  84           wvdwpp=weights(16)
  85           wbond=weights(17)
  86           scal14=weights(18)
  87           wsccor=weights(21)
  88           wsct=weights(22)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102 #ifdef MPI
 103       time00=MPI_Wtime()
 104 #else
 105       time00=tcpu()
 106 #endif
 107 #endif
 108 C
 109 C Compute the side-chain and electrostatic interaction energy
 110 C
 111       goto (101,102,103,104,105,106) ipot
 112 C Lennard-Jones potential.
 113   101 call elj(evdw,evdw_p,evdw_m)
 114 cd    print '(a)','Exit ELJ'
 115       goto 107
 116 C Lennard-Jones-Kihara potential (shifted).
 117   102 call eljk(evdw,evdw_p,evdw_m)
 118       goto 107
 119 C Berne-Pechukas potential (dilated LJ, angular dependence).
 120   103 call ebp(evdw,evdw_p,evdw_m)
 121       goto 107
 122 C Gay-Berne potential (shifted LJ, angular dependence).
 123   104 call egb(evdw,evdw_p,evdw_m)
 124       goto 107
 125 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 126   105 call egbv(evdw,evdw_p,evdw_m)
 127       goto 107
 128 C Soft-sphere potential
 129   106 call e_softsphere(evdw)
 130 C
 131 C Calculate electrostatic (H-bonding) energy of the main chain.
 132 C
 133   107 continue
 134 cmc
 135 cmc Sep-06: egb takes care of dynamic ss bonds too
 136 cmc
 137 c      if (dyn_ss) call dyn_set_nss
 138
 139 c      print *,"Processor",myrank," computed USCSC"
 140 #ifdef TIMING
 141 #ifdef MPI
 142       time01=MPI_Wtime()
 143 #else
 144       time00=tcpu()
 145 #endif
 146 #endif
 147       call vec_and_deriv
 148 #ifdef TIMING
 149 #ifdef MPI
 150       time_vec=time_vec+MPI_Wtime()-time01
 151 #else
 152       time_vec=time_vec+tcpu()-time01
 153 #endif
 154 #endif
 155 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 156       if (ipot.lt.6) then
 157 #ifdef SPLITELE
 158          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #else
 163          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 164      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 165      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 166      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 167 #endif
 168             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 169          else
 170             ees=0.0d0
 171             evdw1=0.0d0
 172             eel_loc=0.0d0
 173             eello_turn3=0.0d0
 174             eello_turn4=0.0d0
 175          endif
 176       else
 177 c        write (iout,*) "Soft-spheer ELEC potential"
 178         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 179      &   eello_turn4)
 180       endif
 181 c      print *,"Processor",myrank," computed UELEC"
 182 C
 183 C Calculate excluded-volume interaction energy between peptide groups
 184 C and side chains.
 185 C
 186       if (ipot.lt.6) then
 187        if(wscp.gt.0d0) then
 188         call escp(evdw2,evdw2_14)
 189        else
 190         evdw2=0
 191         evdw2_14=0
 192        endif
 193       else
 194 c        write (iout,*) "Soft-sphere SCP potential"
 195         call escp_soft_sphere(evdw2,evdw2_14)
 196       endif
 197 c
 198 c Calculate the bond-stretching energy
 199 c
 200       call ebond(estr)
 201 C
 202 C Calculate the disulfide-bridge and other energy and the contributions
 203 C from other distance constraints.
 204 cd    print *,'Calling EHPB'
 205       call edis(ehpb)
 206 cd    print *,'EHPB exitted succesfully.'
 207 C
 208 C Calculate the virtual-bond-angle energy.
 209 C
 210       if (wang.gt.0d0) then
 211         call ebend(ebe)
 212       else
 213         ebe=0
 214       endif
 215 c      print *,"Processor",myrank," computed UB"
 216 C
 217 C Calculate the SC local energy.
 218 C
 219       call esc(escloc)
 220 c      print *,"Processor",myrank," computed USC"
 221 C
 222 C Calculate the virtual-bond torsional energy.
 223 C
 224 cd    print *,'nterm=',nterm
 225       if (wtor.gt.0) then
 226        call etor(etors,edihcnstr)
 227       else
 228        etors=0
 229        edihcnstr=0
 230       endif
 231 c      print *,"Processor",myrank," computed Utor"
 232 C
 233 C 6/23/01 Calculate double-torsional energy
 234 C
 235       if (wtor_d.gt.0) then
 236        call etor_d(etors_d)
 237       else
 238        etors_d=0
 239       endif
 240 c      print *,"Processor",myrank," computed Utord"
 241 C
 242 C 21/5/07 Calculate local sicdechain correlation energy
 243 C
 244       if (wsccor.gt.0.0d0) then
 245         call eback_sc_corr(esccor)
 246       else
 247         esccor=0.0d0
 248       endif
 249 c      print *,"Processor",myrank," computed Usccorr"
 250 C
 251 C 12/1/95 Multi-body terms
 252 C
 253       n_corr=0
 254       n_corr1=0
 255       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 256      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 257          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 258 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 259 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 260       else
 261          ecorr=0.0d0
 262          ecorr5=0.0d0
 263          ecorr6=0.0d0
 264          eturn6=0.0d0
 265       endif
 266       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 267          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 268 cd         write (iout,*) "multibody_hb ecorr",ecorr
 269       endif
 270 c      print *,"Processor",myrank," computed Ucorr"
 271 C
 272 C If performing constraint dynamics, call the constraint energy
 273 C  after the equilibration time
 274       if(usampl.and.totT.gt.eq_time) then
 275          call EconstrQ
 276          call Econstr_back
 277       else
 278          Uconst=0.0d0
 279          Uconst_back=0.0d0
 280       endif
 281 #ifdef TIMING
 282 #ifdef MPI
 283       time_enecalc=time_enecalc+MPI_Wtime()-time00
 284 #else
 285       time_enecalc=time_enecalc+tcpu()-time00
 286 #endif
 287 #endif
 288 c      print *,"Processor",myrank," computed Uconstr"
 289 #ifdef TIMING
 290 #ifdef MPI
 291       time00=MPI_Wtime()
 292 #else
 293       time00=tcpu()
 294 #endif
 295 #endif
 296 c
 297 C Sum the energies
 298 C
 299       energia(1)=evdw
 300 #ifdef SCP14
 301       energia(2)=evdw2-evdw2_14
 302       energia(18)=evdw2_14
 303 #else
 304       energia(2)=evdw2
 305       energia(18)=0.0d0
 306 #endif
 307 #ifdef SPLITELE
 308       energia(3)=ees
 309       energia(16)=evdw1
 310 #else
 311       energia(3)=ees+evdw1
 312       energia(16)=0.0d0
 313 #endif
 314       energia(4)=ecorr
 315       energia(5)=ecorr5
 316       energia(6)=ecorr6
 317       energia(7)=eel_loc
 318       energia(8)=eello_turn3
 319       energia(9)=eello_turn4
 320       energia(10)=eturn6
 321       energia(11)=ebe
 322       energia(12)=escloc
 323       energia(13)=etors
 324       energia(14)=etors_d
 325       energia(15)=ehpb
 326       energia(19)=edihcnstr
 327       energia(17)=estr
 328       energia(20)=Uconst+Uconst_back
 329       energia(21)=esccor
 330       energia(22)=evdw_p
 331       energia(23)=evdw_m
 332 c      print *," Processor",myrank," calls SUM_ENERGY"
 333       call sum_energy(energia,.true.)
 334       if (dyn_ss) call dyn_set_nss
 335 c      print *," Processor",myrank," left SUM_ENERGY"
 336 #ifdef TIMING
 337 #ifdef MPI
 338       time_sumene=time_sumene+MPI_Wtime()-time00
 339 #else
 340       time_sumene=time_sumene+tcpu()-time00
 341 #endif
 342 #endif
 343       return
 344       end
 345 c-------------------------------------------------------------------------------
 346       subroutine sum_energy(energia,reduce)
 347       implicit real*8 (a-h,o-z)
 348       include 'DIMENSIONS'
 349 #ifndef ISNAN
 350       external proc_proc
 351 #ifdef WINPGI
 352 cMS$ATTRIBUTES C ::  proc_proc
 353 #endif
 354 #endif
 355 #ifdef MPI
 356       include "mpif.h"
 357 #endif
 358       include 'COMMON.SETUP'
 359       include 'COMMON.IOUNITS'
 360       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 361       include 'COMMON.FFIELD'
 362       include 'COMMON.DERIV'
 363       include 'COMMON.INTERACT'
 364       include 'COMMON.SBRIDGE'
 365       include 'COMMON.CHAIN'
 366       include 'COMMON.VAR'
 367       include 'COMMON.CONTROL'
 368       include 'COMMON.TIME1'
 369       logical reduce
 370 #ifdef MPI
 371       if (nfgtasks.gt.1 .and. reduce) then
 372 #ifdef DEBUG
 373         write (iout,*) "energies before REDUCE"
 374         call enerprint(energia)
 375         call flush(iout)
 376 #endif
 377         do i=0,n_ene
 378           enebuff(i)=energia(i)
 379         enddo
 380         time00=MPI_Wtime()
 381         call MPI_Barrier(FG_COMM,IERR)
 382         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 383         time00=MPI_Wtime()
 384         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 385      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 386 #ifdef DEBUG
 387         write (iout,*) "energies after REDUCE"
 388         call enerprint(energia)
 389         call flush(iout)
 390 #endif
 391         time_Reduce=time_Reduce+MPI_Wtime()-time00
 392       endif
 393       if (fg_rank.eq.0) then
 394 #endif
 395 #ifdef TSCSC
 396       evdw=energia(22)+wsct*energia(23)
 397 #else
 398       evdw=energia(1)
 399 #endif
 400 #ifdef SCP14
 401       evdw2=energia(2)+energia(18)
 402       evdw2_14=energia(18)
 403 #else
 404       evdw2=energia(2)
 405 #endif
 406 #ifdef SPLITELE
 407       ees=energia(3)
 408       evdw1=energia(16)
 409 #else
 410       ees=energia(3)
 411       evdw1=0.0d0
 412 #endif
 413       ecorr=energia(4)
 414       ecorr5=energia(5)
 415       ecorr6=energia(6)
 416       eel_loc=energia(7)
 417       eello_turn3=energia(8)
 418       eello_turn4=energia(9)
 419       eturn6=energia(10)
 420       ebe=energia(11)
 421       escloc=energia(12)
 422       etors=energia(13)
 423       etors_d=energia(14)
 424       ehpb=energia(15)
 425       edihcnstr=energia(19)
 426       estr=energia(17)
 427       Uconst=energia(20)
 428       esccor=energia(21)
 429 #ifdef SPLITELE
 430       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 431      & +wang*ebe+wtor*etors+wscloc*escloc
 432      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 433      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 434      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 435      & +wbond*estr+Uconst+wsccor*esccor
 436 #else
 437       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 438      & +wang*ebe+wtor*etors+wscloc*escloc
 439      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 440      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 441      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 442      & +wbond*estr+Uconst+wsccor*esccor
 443 #endif
 444       energia(0)=etot
 445 c detecting NaNQ
 446 #ifdef ISNAN
 447 #ifdef AIX
 448       if (isnan(etot).ne.0) energia(0)=1.0d+99
 449 #else
 450       if (isnan(etot)) energia(0)=1.0d+99
 451 #endif
 452 #else
 453       i=0
 454 #ifdef WINPGI
 455       idumm=proc_proc(etot,i)
 456 #else
 457       call proc_proc(etot,i)
 458 #endif
 459       if(i.eq.1)energia(0)=1.0d+99
 460 #endif
 461 #ifdef MPI
 462       endif
 463 #endif
 464       return
 465       end
 466 c-------------------------------------------------------------------------------
 467       subroutine sum_gradient
 468       implicit real*8 (a-h,o-z)
 469       include 'DIMENSIONS'
 470 #ifndef ISNAN
 471       external proc_proc
 472 #ifdef WINPGI
 473 cMS$ATTRIBUTES C ::  proc_proc
 474 #endif
 475 #endif
 476 #ifdef MPI
 477       include 'mpif.h'
 478 #endif
 479       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 480      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 481       include 'COMMON.SETUP'
 482       include 'COMMON.IOUNITS'
 483       include 'COMMON.FFIELD'
 484       include 'COMMON.DERIV'
 485       include 'COMMON.INTERACT'
 486       include 'COMMON.SBRIDGE'
 487       include 'COMMON.CHAIN'
 488       include 'COMMON.VAR'
 489       include 'COMMON.CONTROL'
 490       include 'COMMON.TIME1'
 491       include 'COMMON.MAXGRAD'
 492       include 'COMMON.SCCOR'
 493 #ifdef TIMING
 494 #ifdef MPI
 495       time01=MPI_Wtime()
 496 #else
 497       time01=tcpu()
 498 #endif
 499 #endif
 500 #ifdef DEBUG
 501       write (iout,*) "sum_gradient gvdwc, gvdwx"
 502       do i=1,nres
 503         write (iout,'(i3,3f10.5,5x,3f10.5,5x,3f10.5,5x,3f10.5)')
 504      &   i,(gvdwx(j,i),j=1,3),(gvdwcT(j,i),j=1,3),(gvdwc(j,i),j=1,3),
 505      &   (gvdwcT(j,i),j=1,3)
 506       enddo
 507       call flush(iout)
 508 #endif
 509 #ifdef MPI
 510 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 511         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 512      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 513 #endif
 514 C
 515 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 516 C            in virtual-bond-vector coordinates
 517 C
 518 #ifdef DEBUG
 519 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 520 c      do i=1,nres-1
 521 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 522 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 523 c      enddo
 524 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 525 c      do i=1,nres-1
 526 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 527 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 528 c      enddo
 529       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 530       do i=1,nres
 531         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 532      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 533      &   g_corr5_loc(i)
 534       enddo
 535       call flush(iout)
 536 #endif
 537 #ifdef SPLITELE
 538 #ifdef TSCSC
 539       do i=1,nct
 540         do j=1,3
 541           gradbufc(j,i)=wsc*gvdwc(j,i)+wsc*wscT*gvdwcT(j,i)+
 542      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 543      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 544      &                wel_loc*gel_loc_long(j,i)+
 545      &                wcorr*gradcorr_long(j,i)+
 546      &                wcorr5*gradcorr5_long(j,i)+
 547      &                wcorr6*gradcorr6_long(j,i)+
 548      &                wturn6*gcorr6_turn_long(j,i)+
 549      &                wstrain*ghpbc(j,i)
 550         enddo
 551       enddo
 552 #else
 553       do i=1,nct
 554         do j=1,3
 555           gradbufc(j,i)=wsc*gvdwc(j,i)+
 556      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 557      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 558      &                wel_loc*gel_loc_long(j,i)+
 559      &                wcorr*gradcorr_long(j,i)+
 560      &                wcorr5*gradcorr5_long(j,i)+
 561      &                wcorr6*gradcorr6_long(j,i)+
 562      &                wturn6*gcorr6_turn_long(j,i)+
 563      &                wstrain*ghpbc(j,i)
 564         enddo
 565       enddo
 566 #endif
 567 #else
 568       do i=1,nct
 569         do j=1,3
 570           gradbufc(j,i)=wsc*gvdwc(j,i)+
 571      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 572      &                welec*gelc_long(j,i)+
 573      &                wbond*gradb(j,i)+
 574      &                wel_loc*gel_loc_long(j,i)+
 575      &                wcorr*gradcorr_long(j,i)+
 576      &                wcorr5*gradcorr5_long(j,i)+
 577      &                wcorr6*gradcorr6_long(j,i)+
 578      &                wturn6*gcorr6_turn_long(j,i)+
 579      &                wstrain*ghpbc(j,i)
 580         enddo
 581       enddo
 582 #endif
 583 #ifdef MPI
 584       if (nfgtasks.gt.1) then
 585       time00=MPI_Wtime()
 586 #ifdef DEBUG
 587       write (iout,*) "gradbufc before allreduce"
 588       do i=1,nres
 589         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 590       enddo
 591       call flush(iout)
 592 #endif
 593       do i=1,nres
 594         do j=1,3
 595           gradbufc_sum(j,i)=gradbufc(j,i)
 596         enddo
 597       enddo
 598 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 599 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 600 c      time_reduce=time_reduce+MPI_Wtime()-time00
 601 #ifdef DEBUG
 602 c      write (iout,*) "gradbufc_sum after allreduce"
 603 c      do i=1,nres
 604 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 605 c      enddo
 606 c      call flush(iout)
 607 #endif
 608 #ifdef TIMING
 609 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 610 #endif
 611       do i=nnt,nres
 612         do k=1,3
 613           gradbufc(k,i)=0.0d0
 614         enddo
 615       enddo
 616 #ifdef DEBUG
 617       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 618       write (iout,*) (i," jgrad_start",jgrad_start(i),
 619      &                  " jgrad_end  ",jgrad_end(i),
 620      &                  i=igrad_start,igrad_end)
 621 #endif
 622 c
 623 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 624 c do not parallelize this part.
 625 c
 626 c      do i=igrad_start,igrad_end
 627 c        do j=jgrad_start(i),jgrad_end(i)
 628 c          do k=1,3
 629 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 630 c          enddo
 631 c        enddo
 632 c      enddo
 633       do j=1,3
 634         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 635       enddo
 636       do i=nres-2,nnt,-1
 637         do j=1,3
 638           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 639         enddo
 640       enddo
 641 #ifdef DEBUG
 642       write (iout,*) "gradbufc after summing"
 643       do i=1,nres
 644         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 645       enddo
 646       call flush(iout)
 647 #endif
 648       else
 649 #endif
 650 #ifdef DEBUG
 651       write (iout,*) "gradbufc"
 652       do i=1,nres
 653         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 654       enddo
 655       call flush(iout)
 656 #endif
 657       do i=1,nres
 658         do j=1,3
 659           gradbufc_sum(j,i)=gradbufc(j,i)
 660           gradbufc(j,i)=0.0d0
 661         enddo
 662       enddo
 663       do j=1,3
 664         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 665       enddo
 666       do i=nres-2,nnt,-1
 667         do j=1,3
 668           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 669         enddo
 670       enddo
 671 c      do i=nnt,nres-1
 672 c        do k=1,3
 673 c          gradbufc(k,i)=0.0d0
 674 c        enddo
 675 c        do j=i+1,nres
 676 c          do k=1,3
 677 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 678 c          enddo
 679 c        enddo
 680 c      enddo
 681 #ifdef DEBUG
 682       write (iout,*) "gradbufc after summing"
 683       do i=1,nres
 684         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 685       enddo
 686       call flush(iout)
 687 #endif
 688 #ifdef MPI
 689       endif
 690 #endif
 691       do k=1,3
 692         gradbufc(k,nres)=0.0d0
 693       enddo
 694       do i=1,nct
 695         do j=1,3
 696 #ifdef SPLITELE
 697           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 698      &                wel_loc*gel_loc(j,i)+
 699      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 700      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 701      &                wel_loc*gel_loc_long(j,i)+
 702      &                wcorr*gradcorr_long(j,i)+
 703      &                wcorr5*gradcorr5_long(j,i)+
 704      &                wcorr6*gradcorr6_long(j,i)+
 705      &                wturn6*gcorr6_turn_long(j,i))+
 706      &                wbond*gradb(j,i)+
 707      &                wcorr*gradcorr(j,i)+
 708      &                wturn3*gcorr3_turn(j,i)+
 709      &                wturn4*gcorr4_turn(j,i)+
 710      &                wcorr5*gradcorr5(j,i)+
 711      &                wcorr6*gradcorr6(j,i)+
 712      &                wturn6*gcorr6_turn(j,i)+
 713      &                wsccor*gsccorc(j,i)
 714      &               +wscloc*gscloc(j,i)
 715 #else
 716           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 717      &                wel_loc*gel_loc(j,i)+
 718      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 719      &                welec*gelc_long(j,i)+
 720      &                wel_loc*gel_loc_long(j,i)+
 721      &                wcorr*gcorr_long(j,i)+
 722      &                wcorr5*gradcorr5_long(j,i)+
 723      &                wcorr6*gradcorr6_long(j,i)+
 724      &                wturn6*gcorr6_turn_long(j,i))+
 725      &                wbond*gradb(j,i)+
 726      &                wcorr*gradcorr(j,i)+
 727      &                wturn3*gcorr3_turn(j,i)+
 728      &                wturn4*gcorr4_turn(j,i)+
 729      &                wcorr5*gradcorr5(j,i)+
 730      &                wcorr6*gradcorr6(j,i)+
 731      &                wturn6*gcorr6_turn(j,i)+
 732      &                wsccor*gsccorc(j,i)
 733      &               +wscloc*gscloc(j,i)
 734 #endif
 735 #ifdef TSCSC
 736           gradx(j,i,icg)=wsc*gvdwx(j,i)+wsc*wscT*gvdwxT(j,i)+
 737      &                  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 #else
 743           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 744      &                  wbond*gradbx(j,i)+
 745      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 746      &                  wsccor*gsccorx(j,i)
 747      &                 +wscloc*gsclocx(j,i)
 748 #endif
 749         enddo
 750       enddo
 751 #ifdef DEBUG
 752       write (iout,*) "gloc before adding corr"
 753       do i=1,4*nres
 754         write (iout,*) i,gloc(i,icg)
 755       enddo
 756 #endif
 757       do i=1,nres-3
 758         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 759      &   +wcorr5*g_corr5_loc(i)
 760      &   +wcorr6*g_corr6_loc(i)
 761      &   +wturn4*gel_loc_turn4(i)
 762      &   +wturn3*gel_loc_turn3(i)
 763      &   +wturn6*gel_loc_turn6(i)
 764      &   +wel_loc*gel_loc_loc(i)
 765       enddo
 766 #ifdef DEBUG
 767       write (iout,*) "gloc after adding corr"
 768       do i=1,4*nres
 769         write (iout,*) i,gloc(i,icg)
 770       enddo
 771 #endif
 772 #ifdef MPI
 773       if (nfgtasks.gt.1) then
 774         do j=1,3
 775           do i=1,nres
 776             gradbufc(j,i)=gradc(j,i,icg)
 777             gradbufx(j,i)=gradx(j,i,icg)
 778           enddo
 779         enddo
 780         do i=1,4*nres
 781           glocbuf(i)=gloc(i,icg)
 782         enddo
 783 #ifdef DEBUG
 784       write (iout,*) "gloc_sc before reduce"
 785       do i=1,nres
 786        do j=1,3
 787         write (iout,*) i,j,gloc_sc(j,i,icg)
 788        enddo
 789       enddo
 790 #endif
 791         do i=1,nres
 792          do j=1,3
 793           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 794          enddo
 795         enddo
 796         time00=MPI_Wtime()
 797         call MPI_Barrier(FG_COMM,IERR)
 798         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 799         time00=MPI_Wtime()
 800         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 801      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 802         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 803      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 804         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 805      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 806         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 807      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 808         time_reduce=time_reduce+MPI_Wtime()-time00
 809 #ifdef DEBUG
 810       write (iout,*) "gloc_sc after reduce"
 811       do i=1,nres
 812        do j=1,3
 813         write (iout,*) i,j,gloc_sc(j,i,icg)
 814        enddo
 815       enddo
 816 #endif
 817 #ifdef DEBUG
 818       write (iout,*) "gloc after reduce"
 819       do i=1,4*nres
 820         write (iout,*) i,gloc(i,icg)
 821       enddo
 822 #endif
 823       endif
 824 #endif
 825       if (gnorm_check) then
 826 c
 827 c Compute the maximum elements of the gradient
 828 c
 829       gvdwc_max=0.0d0
 830       gvdwc_scp_max=0.0d0
 831       gelc_max=0.0d0
 832       gvdwpp_max=0.0d0
 833       gradb_max=0.0d0
 834       ghpbc_max=0.0d0
 835       gradcorr_max=0.0d0
 836       gel_loc_max=0.0d0
 837       gcorr3_turn_max=0.0d0
 838       gcorr4_turn_max=0.0d0
 839       gradcorr5_max=0.0d0
 840       gradcorr6_max=0.0d0
 841       gcorr6_turn_max=0.0d0
 842       gsccorc_max=0.0d0
 843       gscloc_max=0.0d0
 844       gvdwx_max=0.0d0
 845       gradx_scp_max=0.0d0
 846       ghpbx_max=0.0d0
 847       gradxorr_max=0.0d0
 848       gsccorx_max=0.0d0
 849       gsclocx_max=0.0d0
 850       do i=1,nct
 851         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 852         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 853 #ifdef TSCSC
 854         gvdwc_norm=dsqrt(scalar(gvdwcT(1,i),gvdwcT(1,i)))
 855         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 856 #endif
 857         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 858         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 859      &   gvdwc_scp_max=gvdwc_scp_norm
 860         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 861         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 862         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 863         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 864         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 865         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 866         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 867         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 868         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 869         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 870         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 871         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 872         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 873      &    gcorr3_turn(1,i)))
 874         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 875      &    gcorr3_turn_max=gcorr3_turn_norm
 876         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 877      &    gcorr4_turn(1,i)))
 878         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 879      &    gcorr4_turn_max=gcorr4_turn_norm
 880         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 881         if (gradcorr5_norm.gt.gradcorr5_max)
 882      &    gradcorr5_max=gradcorr5_norm
 883         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 884         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 885         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 886      &    gcorr6_turn(1,i)))
 887         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 888      &    gcorr6_turn_max=gcorr6_turn_norm
 889         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 890         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 891         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 892         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 893         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 894         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 895 #ifdef TSCSC
 896         gvdwx_norm=dsqrt(scalar(gvdwxT(1,i),gvdwxT(1,i)))
 897         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 898 #endif
 899         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 900         if (gradx_scp_norm.gt.gradx_scp_max)
 901      &    gradx_scp_max=gradx_scp_norm
 902         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 903         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 904         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 905         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 906         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 907         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 908         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 909         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 910       enddo
 911       if (gradout) then
 912 #ifdef AIX
 913         open(istat,file=statname,position="append")
 914 #else
 915         open(istat,file=statname,access="append")
 916 #endif
 917         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 918      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 919      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 920      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 921      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 922      &     gsccorx_max,gsclocx_max
 923         close(istat)
 924         if (gvdwc_max.gt.1.0d4) then
 925           write (iout,*) "gvdwc gvdwx gradb gradbx"
 926           do i=nnt,nct
 927             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 928      &        gradb(j,i),gradbx(j,i),j=1,3)
 929           enddo
 930           call pdbout(0.0d0,'cipiszcze',iout)
 931           call flush(iout)
 932         endif
 933       endif
 934       endif
 935 #ifdef DEBUG
 936       write (iout,*) "gradc gradx gloc"
 937       do i=1,nres
 938         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 939      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 940       enddo
 941 #endif
 942 #ifdef TIMING
 943 #ifdef MPI
 944       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 945 #else
 946       time_sumgradient=time_sumgradient+tcpu()-time01
 947 #endif
 948 #endif
 949       return
 950       end
 951 c-------------------------------------------------------------------------------
 952       subroutine rescale_weights(t_bath)
 953       implicit real*8 (a-h,o-z)
 954       include 'DIMENSIONS'
 955       include 'COMMON.IOUNITS'
 956       include 'COMMON.FFIELD'
 957       include 'COMMON.SBRIDGE'
 958       double precision kfac /2.4d0/
 959       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 960 c      facT=temp0/t_bath
 961 c      facT=2*temp0/(t_bath+temp0)
 962       if (rescale_mode.eq.0) then
 963         facT=1.0d0
 964         facT2=1.0d0
 965         facT3=1.0d0
 966         facT4=1.0d0
 967         facT5=1.0d0
 968       else if (rescale_mode.eq.1) then
 969         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 970         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 971         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 972         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 973         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 974       else if (rescale_mode.eq.2) then
 975         x=t_bath/temp0
 976         x2=x*x
 977         x3=x2*x
 978         x4=x3*x
 979         x5=x4*x
 980         facT=licznik/dlog(dexp(x)+dexp(-x))
 981         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 982         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 983         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 984         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 985       else
 986         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 987         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 988 #ifdef MPI
 989        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 990 #endif
 991        stop 555
 992       endif
 993       welec=weights(3)*fact
 994       wcorr=weights(4)*fact3
 995       wcorr5=weights(5)*fact4
 996       wcorr6=weights(6)*fact5
 997       wel_loc=weights(7)*fact2
 998       wturn3=weights(8)*fact2
 999       wturn4=weights(9)*fact3
1000       wturn6=weights(10)*fact5
1001       wtor=weights(13)*fact
1002       wtor_d=weights(14)*fact2
1003       wsccor=weights(21)*fact
1004 #ifdef TSCSC
1005 c      wsct=t_bath/temp0
1006       wsct=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1007 #endif
1008       return
1009       end
1010 C------------------------------------------------------------------------
1011       subroutine enerprint(energia)
1012       implicit real*8 (a-h,o-z)
1013       include 'DIMENSIONS'
1014       include 'COMMON.IOUNITS'
1015       include 'COMMON.FFIELD'
1016       include 'COMMON.SBRIDGE'
1017       include 'COMMON.MD'
1018       double precision energia(0:n_ene)
1019       etot=energia(0)
1020 #ifdef TSCSC
1021       evdw=energia(22)+wsct*energia(23)
1022 #else
1023       evdw=energia(1)
1024 #endif
1025       evdw2=energia(2)
1026 #ifdef SCP14
1027       evdw2=energia(2)+energia(18)
1028 #else
1029       evdw2=energia(2)
1030 #endif
1031       ees=energia(3)
1032 #ifdef SPLITELE
1033       evdw1=energia(16)
1034 #endif
1035       ecorr=energia(4)
1036       ecorr5=energia(5)
1037       ecorr6=energia(6)
1038       eel_loc=energia(7)
1039       eello_turn3=energia(8)
1040       eello_turn4=energia(9)
1041       eello_turn6=energia(10)
1042       ebe=energia(11)
1043       escloc=energia(12)
1044       etors=energia(13)
1045       etors_d=energia(14)
1046       ehpb=energia(15)
1047       edihcnstr=energia(19)
1048       estr=energia(17)
1049       Uconst=energia(20)
1050       esccor=energia(21)
1051 #ifdef SPLITELE
1052       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1053      &  estr,wbond,ebe,wang,
1054      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1055      &  ecorr,wcorr,
1056      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1057      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
1058      &  edihcnstr,ebr*nss,
1059      &  Uconst,etot
1060    10 format (/'Virtual-chain energies:'//
1061      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-SC)'/
1062      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pE16.6,' (SC-p)'/
1063      & 'EES=   ',1pE16.6,' WEIGHT=',1pE16.6,' (p-p)'/
1064      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pE16.6,' (p-p VDW)'/
1065      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pE16.6,' (stretching)'/
1066      & 'EBE=   ',1pE16.6,' WEIGHT=',1pE16.6,' (bending)'/
1067      & 'ESC=   ',1pE16.6,' WEIGHT=',1pE16.6,' (SC local)'/
1068      & 'ETORS= ',1pE16.6,' WEIGHT=',1pE16.6,' (torsional)'/
1069      & 'ETORSD=',1pE16.6,' WEIGHT=',1pE16.6,' (double torsional)'/
1070      & 'EHPB=  ',1pE16.6,' WEIGHT=',1pE16.6,
1071      & ' (SS bridges & dist. cnstr.)'/
1072      & 'ECORR4=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1073      & 'ECORR5=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1074      & 'ECORR6=',1pE16.6,' WEIGHT=',1pE16.6,' (multi-body)'/
1075      & 'EELLO= ',1pE16.6,' WEIGHT=',1pE16.6,' (electrostatic-local)'/
1076      & 'ETURN3=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 3rd order)'/
1077      & 'ETURN4=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 4th order)'/
1078      & 'ETURN6=',1pE16.6,' WEIGHT=',1pE16.6,' (turns, 6th order)'/
1079      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pE16.6,' (backbone-rotamer corr)'/
1080      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1081      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1082      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1083      & 'ETOT=  ',1pE16.6,' (total)')
1084 #else
1085       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1086      &  estr,wbond,ebe,wang,
1087      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1088      &  ecorr,wcorr,
1089      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1090      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1091      &  ebr*nss,Uconst,etot
1092    10 format (/'Virtual-chain energies:'//
1093      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1094      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1095      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1096      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1097      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1098      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1099      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1100      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1101      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1102      & ' (SS bridges & dist. cnstr.)'/
1103      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1104      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1105      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1106      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1107      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1108      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1109      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1110      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1111      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1112      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1113      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1114      & 'ETOT=  ',1pE16.6,' (total)')
1115 #endif
1116       return
1117       end
1118 C-----------------------------------------------------------------------
1119       subroutine elj(evdw,evdw_p,evdw_m)
1120 C
1121 C This subroutine calculates the interaction energy of nonbonded side chains
1122 C assuming the LJ potential of interaction.
1123 C
1124       implicit real*8 (a-h,o-z)
1125       include 'DIMENSIONS'
1126       parameter (accur=1.0d-10)
1127       include 'COMMON.GEO'
1128       include 'COMMON.VAR'
1129       include 'COMMON.LOCAL'
1130       include 'COMMON.CHAIN'
1131       include 'COMMON.DERIV'
1132       include 'COMMON.INTERACT'
1133       include 'COMMON.TORSION'
1134       include 'COMMON.SBRIDGE'
1135       include 'COMMON.NAMES'
1136       include 'COMMON.IOUNITS'
1137       include 'COMMON.CONTACTS'
1138       dimension gg(3)
1139 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1140       evdw=0.0D0
1141       do i=iatsc_s,iatsc_e
1142         itypi=itype(i)
1143         itypi1=itype(i+1)
1144         xi=c(1,nres+i)
1145         yi=c(2,nres+i)
1146         zi=c(3,nres+i)
1147 C Change 12/1/95
1148         num_conti=0
1149 C
1150 C Calculate SC interaction energy.
1151 C
1152         do iint=1,nint_gr(i)
1153 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1154 cd   &                  'iend=',iend(i,iint)
1155           do j=istart(i,iint),iend(i,iint)
1156             itypj=itype(j)
1157             xj=c(1,nres+j)-xi
1158             yj=c(2,nres+j)-yi
1159             zj=c(3,nres+j)-zi
1160 C Change 12/1/95 to calculate four-body interactions
1161             rij=xj*xj+yj*yj+zj*zj
1162             rrij=1.0D0/rij
1163 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1164             eps0ij=eps(itypi,itypj)
1165             fac=rrij**expon2
1166             e1=fac*fac*aa(itypi,itypj)
1167             e2=fac*bb(itypi,itypj)
1168             evdwij=e1+e2
1169 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1170 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1171 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1172 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1173 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1174 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1175 #ifdef TSCSC
1176             if (bb(itypi,itypj).gt.0) then
1177                evdw_p=evdw_p+evdwij
1178             else
1179                evdw_m=evdw_m+evdwij
1180             endif
1181 #else
1182             evdw=evdw+evdwij
1183 #endif
1184 C
1185 C Calculate the components of the gradient in DC and X
1186 C
1187             fac=-rrij*(e1+evdwij)
1188             gg(1)=xj*fac
1189             gg(2)=yj*fac
1190             gg(3)=zj*fac
1191 #ifdef TSCSC
1192             if (bb(itypi,itypj).gt.0.0d0) then
1193               do k=1,3
1194                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1195                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1196                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1197                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1198               enddo
1199             else
1200               do k=1,3
1201                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1202                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1203                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1204                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1205               enddo
1206             endif
1207 #else
1208             do k=1,3
1209               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1210               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1211               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1212               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1213             enddo
1214 #endif
1215 cgrad            do k=i,j-1
1216 cgrad              do l=1,3
1217 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1218 cgrad              enddo
1219 cgrad            enddo
1220 C
1221 C 12/1/95, revised on 5/20/97
1222 C
1223 C Calculate the contact function. The ith column of the array JCONT will
1224 C contain the numbers of atoms that make contacts with the atom I (of numbers
1225 C greater than I). The arrays FACONT and GACONT will contain the values of
1226 C the contact function and its derivative.
1227 C
1228 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1229 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1230 C Uncomment next line, if the correlation interactions are contact function only
1231             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1232               rij=dsqrt(rij)
1233               sigij=sigma(itypi,itypj)
1234               r0ij=rs0(itypi,itypj)
1235 C
1236 C Check whether the SC's are not too far to make a contact.
1237 C
1238               rcut=1.5d0*r0ij
1239               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1240 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1241 C
1242               if (fcont.gt.0.0D0) then
1243 C If the SC-SC distance if close to sigma, apply spline.
1244 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1245 cAdam &             fcont1,fprimcont1)
1246 cAdam           fcont1=1.0d0-fcont1
1247 cAdam           if (fcont1.gt.0.0d0) then
1248 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1249 cAdam             fcont=fcont*fcont1
1250 cAdam           endif
1251 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1252 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1253 cga             do k=1,3
1254 cga               gg(k)=gg(k)*eps0ij
1255 cga             enddo
1256 cga             eps0ij=-evdwij*eps0ij
1257 C Uncomment for AL's type of SC correlation interactions.
1258 cadam           eps0ij=-evdwij
1259                 num_conti=num_conti+1
1260                 jcont(num_conti,i)=j
1261                 facont(num_conti,i)=fcont*eps0ij
1262                 fprimcont=eps0ij*fprimcont/rij
1263                 fcont=expon*fcont
1264 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1265 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1266 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1267 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1268                 gacont(1,num_conti,i)=-fprimcont*xj
1269                 gacont(2,num_conti,i)=-fprimcont*yj
1270                 gacont(3,num_conti,i)=-fprimcont*zj
1271 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1272 cd              write (iout,'(2i3,3f10.5)')
1273 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1274               endif
1275             endif
1276           enddo      ! j
1277         enddo        ! iint
1278 C Change 12/1/95
1279         num_cont(i)=num_conti
1280       enddo          ! i
1281       do i=1,nct
1282         do j=1,3
1283           gvdwc(j,i)=expon*gvdwc(j,i)
1284           gvdwx(j,i)=expon*gvdwx(j,i)
1285         enddo
1286       enddo
1287 C******************************************************************************
1288 C
1289 C                              N O T E !!!
1290 C
1291 C To save time, the factor of EXPON has been extracted from ALL components
1292 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1293 C use!
1294 C
1295 C******************************************************************************
1296       return
1297       end
1298 C-----------------------------------------------------------------------------
1299       subroutine eljk(evdw,evdw_p,evdw_m)
1300 C
1301 C This subroutine calculates the interaction energy of nonbonded side chains
1302 C assuming the LJK potential of interaction.
1303 C
1304       implicit real*8 (a-h,o-z)
1305       include 'DIMENSIONS'
1306       include 'COMMON.GEO'
1307       include 'COMMON.VAR'
1308       include 'COMMON.LOCAL'
1309       include 'COMMON.CHAIN'
1310       include 'COMMON.DERIV'
1311       include 'COMMON.INTERACT'
1312       include 'COMMON.IOUNITS'
1313       include 'COMMON.NAMES'
1314       dimension gg(3)
1315       logical scheck
1316 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1317       evdw=0.0D0
1318       do i=iatsc_s,iatsc_e
1319         itypi=itype(i)
1320         itypi1=itype(i+1)
1321         xi=c(1,nres+i)
1322         yi=c(2,nres+i)
1323         zi=c(3,nres+i)
1324 C
1325 C Calculate SC interaction energy.
1326 C
1327         do iint=1,nint_gr(i)
1328           do j=istart(i,iint),iend(i,iint)
1329             itypj=itype(j)
1330             xj=c(1,nres+j)-xi
1331             yj=c(2,nres+j)-yi
1332             zj=c(3,nres+j)-zi
1333             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1334             fac_augm=rrij**expon
1335             e_augm=augm(itypi,itypj)*fac_augm
1336             r_inv_ij=dsqrt(rrij)
1337             rij=1.0D0/r_inv_ij
1338             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1339             fac=r_shift_inv**expon
1340             e1=fac*fac*aa(itypi,itypj)
1341             e2=fac*bb(itypi,itypj)
1342             evdwij=e_augm+e1+e2
1343 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1344 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1345 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1346 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1347 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1348 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1349 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1350 #ifdef TSCSC
1351             if (bb(itypi,itypj).gt.0) then
1352                evdw_p=evdw_p+evdwij
1353             else
1354                evdw_m=evdw_m+evdwij
1355             endif
1356 #else
1357             evdw=evdw+evdwij
1358 #endif
1359 C
1360 C Calculate the components of the gradient in DC and X
1361 C
1362             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1363             gg(1)=xj*fac
1364             gg(2)=yj*fac
1365             gg(3)=zj*fac
1366 #ifdef TSCSC
1367             if (bb(itypi,itypj).gt.0.0d0) then
1368               do k=1,3
1369                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
1370                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
1371                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
1372                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
1373               enddo
1374             else
1375               do k=1,3
1376                 gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1377                 gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1378                 gvdwcT(k,i)=gvdwcT(k,i)-gg(k)
1379                 gvdwcT(k,j)=gvdwcT(k,j)+gg(k)
1380               enddo
1381             endif
1382 #else
1383             do k=1,3
1384               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1385               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1386               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1387               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1388             enddo
1389 #endif
1390 cgrad            do k=i,j-1
1391 cgrad              do l=1,3
1392 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1393 cgrad              enddo
1394 cgrad            enddo
1395           enddo      ! j
1396         enddo        ! iint
1397       enddo          ! i
1398       do i=1,nct
1399         do j=1,3
1400           gvdwc(j,i)=expon*gvdwc(j,i)
1401           gvdwx(j,i)=expon*gvdwx(j,i)
1402         enddo
1403       enddo
1404       return
1405       end
1406 C-----------------------------------------------------------------------------
1407       subroutine ebp(evdw,evdw_p,evdw_m)
1408 C
1409 C This subroutine calculates the interaction energy of nonbonded side chains
1410 C assuming the Berne-Pechukas potential of interaction.
1411 C
1412       implicit real*8 (a-h,o-z)
1413       include 'DIMENSIONS'
1414       include 'COMMON.GEO'
1415       include 'COMMON.VAR'
1416       include 'COMMON.LOCAL'
1417       include 'COMMON.CHAIN'
1418       include 'COMMON.DERIV'
1419       include 'COMMON.NAMES'
1420       include 'COMMON.INTERACT'
1421       include 'COMMON.IOUNITS'
1422       include 'COMMON.CALC'
1423       common /srutu/ icall
1424 c     double precision rrsave(maxdim)
1425       logical lprn
1426       evdw=0.0D0
1427 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1428       evdw=0.0D0
1429 c     if (icall.eq.0) then
1430 c       lprn=.true.
1431 c     else
1432         lprn=.false.
1433 c     endif
1434       ind=0
1435       do i=iatsc_s,iatsc_e
1436         itypi=itype(i)
1437         itypi1=itype(i+1)
1438         xi=c(1,nres+i)
1439         yi=c(2,nres+i)
1440         zi=c(3,nres+i)
1441         dxi=dc_norm(1,nres+i)
1442         dyi=dc_norm(2,nres+i)
1443         dzi=dc_norm(3,nres+i)
1444 c        dsci_inv=dsc_inv(itypi)
1445         dsci_inv=vbld_inv(i+nres)
1446 C
1447 C Calculate SC interaction energy.
1448 C
1449         do iint=1,nint_gr(i)
1450           do j=istart(i,iint),iend(i,iint)
1451             ind=ind+1
1452             itypj=itype(j)
1453 c            dscj_inv=dsc_inv(itypj)
1454             dscj_inv=vbld_inv(j+nres)
1455             chi1=chi(itypi,itypj)
1456             chi2=chi(itypj,itypi)
1457             chi12=chi1*chi2
1458             chip1=chip(itypi)
1459             chip2=chip(itypj)
1460             chip12=chip1*chip2
1461             alf1=alp(itypi)
1462             alf2=alp(itypj)
1463             alf12=0.5D0*(alf1+alf2)
1464 C For diagnostics only!!!
1465 c           chi1=0.0D0
1466 c           chi2=0.0D0
1467 c           chi12=0.0D0
1468 c           chip1=0.0D0
1469 c           chip2=0.0D0
1470 c           chip12=0.0D0
1471 c           alf1=0.0D0
1472 c           alf2=0.0D0
1473 c           alf12=0.0D0
1474             xj=c(1,nres+j)-xi
1475             yj=c(2,nres+j)-yi
1476             zj=c(3,nres+j)-zi
1477             dxj=dc_norm(1,nres+j)
1478             dyj=dc_norm(2,nres+j)
1479             dzj=dc_norm(3,nres+j)
1480             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1481 cd          if (icall.eq.0) then
1482 cd            rrsave(ind)=rrij
1483 cd          else
1484 cd            rrij=rrsave(ind)
1485 cd          endif
1486             rij=dsqrt(rrij)
1487 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1488             call sc_angular
1489 C Calculate whole angle-dependent part of epsilon and contributions
1490 C to its derivatives
1491             fac=(rrij*sigsq)**expon2
1492             e1=fac*fac*aa(itypi,itypj)
1493             e2=fac*bb(itypi,itypj)
1494             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1495             eps2der=evdwij*eps3rt
1496             eps3der=evdwij*eps2rt
1497             evdwij=evdwij*eps2rt*eps3rt
1498 #ifdef TSCSC
1499             if (bb(itypi,itypj).gt.0) then
1500                evdw_p=evdw_p+evdwij
1501             else
1502                evdw_m=evdw_m+evdwij
1503             endif
1504 #else
1505             evdw=evdw+evdwij
1506 #endif
1507             if (lprn) then
1508             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1509             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1510 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1511 cd     &        restyp(itypi),i,restyp(itypj),j,
1512 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1513 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1514 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1515 cd     &        evdwij
1516             endif
1517 C Calculate gradient components.
1518             e1=e1*eps1*eps2rt**2*eps3rt**2
1519             fac=-expon*(e1+evdwij)
1520             sigder=fac/sigsq
1521             fac=rrij*fac
1522 C Calculate radial part of the gradient
1523             gg(1)=xj*fac
1524             gg(2)=yj*fac
1525             gg(3)=zj*fac
1526 C Calculate the angular part of the gradient and sum add the contributions
1527 C to the appropriate components of the Cartesian gradient.
1528 #ifdef TSCSC
1529             if (bb(itypi,itypj).gt.0) then
1530                call sc_grad
1531             else
1532                call sc_grad_T
1533             endif
1534 #else
1535             call sc_grad
1536 #endif
1537           enddo      ! j
1538         enddo        ! iint
1539       enddo          ! i
1540 c     stop
1541       return
1542       end
1543 C-----------------------------------------------------------------------------
1544       subroutine egb(evdw,evdw_p,evdw_m)
1545 C
1546 C This subroutine calculates the interaction energy of nonbonded side chains
1547 C assuming the Gay-Berne potential of interaction.
1548 C
1549       implicit real*8 (a-h,o-z)
1550       include 'DIMENSIONS'
1551       include 'COMMON.GEO'
1552       include 'COMMON.VAR'
1553       include 'COMMON.LOCAL'
1554       include 'COMMON.CHAIN'
1555       include 'COMMON.DERIV'
1556       include 'COMMON.NAMES'
1557       include 'COMMON.INTERACT'
1558       include 'COMMON.IOUNITS'
1559       include 'COMMON.CALC'
1560       include 'COMMON.CONTROL'
1561       include 'COMMON.SBRIDGE'
1562       logical lprn
1563       evdw=0.0D0
1564 ccccc      energy_dec=.false.
1565 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1566       evdw=0.0D0
1567       evdw_p=0.0D0
1568       evdw_m=0.0D0
1569       lprn=.false.
1570 c     if (icall.eq.0) lprn=.false.
1571       ind=0
1572       do i=iatsc_s,iatsc_e
1573         itypi=itype(i)
1574         itypi1=itype(i+1)
1575         xi=c(1,nres+i)
1576         yi=c(2,nres+i)
1577         zi=c(3,nres+i)
1578         dxi=dc_norm(1,nres+i)
1579         dyi=dc_norm(2,nres+i)
1580         dzi=dc_norm(3,nres+i)
1581 c        dsci_inv=dsc_inv(itypi)
1582         dsci_inv=vbld_inv(i+nres)
1583 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1584 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1585 C
1586 C Calculate SC interaction energy.
1587 C
1588         do iint=1,nint_gr(i)
1589           do j=istart(i,iint),iend(i,iint)
1590             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1591               call dyn_ssbond_ene(i,j,evdwij)
1592               evdw=evdw+evdwij
1593               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1594      &                        'evdw',i,j,evdwij,' ss'
1595             ELSE
1596             ind=ind+1
1597             itypj=itype(j)
1598 c            dscj_inv=dsc_inv(itypj)
1599             dscj_inv=vbld_inv(j+nres)
1600 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1601 c     &       1.0d0/vbld(j+nres)
1602 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1603             sig0ij=sigma(itypi,itypj)
1604             chi1=chi(itypi,itypj)
1605             chi2=chi(itypj,itypi)
1606             chi12=chi1*chi2
1607             chip1=chip(itypi)
1608             chip2=chip(itypj)
1609             chip12=chip1*chip2
1610             alf1=alp(itypi)
1611             alf2=alp(itypj)
1612             alf12=0.5D0*(alf1+alf2)
1613 C For diagnostics only!!!
1614 c           chi1=0.0D0
1615 c           chi2=0.0D0
1616 c           chi12=0.0D0
1617 c           chip1=0.0D0
1618 c           chip2=0.0D0
1619 c           chip12=0.0D0
1620 c           alf1=0.0D0
1621 c           alf2=0.0D0
1622 c           alf12=0.0D0
1623             xj=c(1,nres+j)-xi
1624             yj=c(2,nres+j)-yi
1625             zj=c(3,nres+j)-zi
1626             dxj=dc_norm(1,nres+j)
1627             dyj=dc_norm(2,nres+j)
1628             dzj=dc_norm(3,nres+j)
1629 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1630 c            write (iout,*) "j",j," dc_norm",
1631 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1632             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1633             rij=dsqrt(rrij)
1634 C Calculate angle-dependent terms of energy and contributions to their
1635 C derivatives.
1636             call sc_angular
1637             sigsq=1.0D0/sigsq
1638             sig=sig0ij*dsqrt(sigsq)
1639             rij_shift=1.0D0/rij-sig+sig0ij
1640 c for diagnostics; uncomment
1641 c            rij_shift=1.2*sig0ij
1642 C I hate to put IF's in the loops, but here don't have another choice!!!!
1643             if (rij_shift.le.0.0D0) then
1644               evdw=1.0D20
1645 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1646 cd     &        restyp(itypi),i,restyp(itypj),j,
1647 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1648               return
1649             endif
1650             sigder=-sig*sigsq
1651 c---------------------------------------------------------------
1652             rij_shift=1.0D0/rij_shift
1653             fac=rij_shift**expon
1654             e1=fac*fac*aa(itypi,itypj)
1655             e2=fac*bb(itypi,itypj)
1656             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1657             eps2der=evdwij*eps3rt
1658             eps3der=evdwij*eps2rt
1659 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1660 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1661             evdwij=evdwij*eps2rt*eps3rt
1662 #ifdef TSCSC
1663             if (bb(itypi,itypj).gt.0) then
1664                evdw_p=evdw_p+evdwij
1665             else
1666                evdw_m=evdw_m+evdwij
1667             endif
1668 #else
1669             evdw=evdw+evdwij
1670 #endif
1671             if (lprn) then
1672             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1673             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1674             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1675      &        restyp(itypi),i,restyp(itypj),j,
1676      &        epsi,sigm,chi1,chi2,chip1,chip2,
1677      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1678      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1679      &        evdwij
1680             endif
1681
1682             if (energy_dec) then
1683               write (iout,'(a6,2i5,0pf7.3)') 'evdw',i,j,evdwij
1684               call flush(iout)
1685             endif
1686 C Calculate gradient components.
1687             e1=e1*eps1*eps2rt**2*eps3rt**2
1688             fac=-expon*(e1+evdwij)*rij_shift
1689             sigder=fac*sigder
1690             fac=rij*fac
1691 c            fac=0.0d0
1692 C Calculate the radial part of the gradient
1693             gg(1)=xj*fac
1694             gg(2)=yj*fac
1695             gg(3)=zj*fac
1696 C Calculate angular part of the gradient.
1697 #ifdef TSCSC
1698             if (bb(itypi,itypj).gt.0) then
1699                call sc_grad
1700             else
1701                call sc_grad_T
1702             endif
1703 #else
1704             call sc_grad
1705 #endif
1706             ENDIF    ! dyn_ss
1707           enddo      ! j
1708         enddo        ! iint
1709       enddo          ! i
1710 c      write (iout,*) "Number of loop steps in EGB:",ind
1711 cccc      energy_dec=.false.
1712       return
1713       end
1714 C-----------------------------------------------------------------------------
1715       subroutine egbv(evdw,evdw_p,evdw_m)
1716 C
1717 C This subroutine calculates the interaction energy of nonbonded side chains
1718 C assuming the Gay-Berne-Vorobjev potential of interaction.
1719 C
1720       implicit real*8 (a-h,o-z)
1721       include 'DIMENSIONS'
1722       include 'COMMON.GEO'
1723       include 'COMMON.VAR'
1724       include 'COMMON.LOCAL'
1725       include 'COMMON.CHAIN'
1726       include 'COMMON.DERIV'
1727       include 'COMMON.NAMES'
1728       include 'COMMON.INTERACT'
1729       include 'COMMON.IOUNITS'
1730       include 'COMMON.CALC'
1731       common /srutu/ icall
1732       logical lprn
1733       evdw=0.0D0
1734 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1735       evdw=0.0D0
1736       lprn=.false.
1737 c     if (icall.eq.0) lprn=.true.
1738       ind=0
1739       do i=iatsc_s,iatsc_e
1740         itypi=itype(i)
1741         itypi1=itype(i+1)
1742         xi=c(1,nres+i)
1743         yi=c(2,nres+i)
1744         zi=c(3,nres+i)
1745         dxi=dc_norm(1,nres+i)
1746         dyi=dc_norm(2,nres+i)
1747         dzi=dc_norm(3,nres+i)
1748 c        dsci_inv=dsc_inv(itypi)
1749         dsci_inv=vbld_inv(i+nres)
1750 C
1751 C Calculate SC interaction energy.
1752 C
1753         do iint=1,nint_gr(i)
1754           do j=istart(i,iint),iend(i,iint)
1755             ind=ind+1
1756             itypj=itype(j)
1757 c            dscj_inv=dsc_inv(itypj)
1758             dscj_inv=vbld_inv(j+nres)
1759             sig0ij=sigma(itypi,itypj)
1760             r0ij=r0(itypi,itypj)
1761             chi1=chi(itypi,itypj)
1762             chi2=chi(itypj,itypi)
1763             chi12=chi1*chi2
1764             chip1=chip(itypi)
1765             chip2=chip(itypj)
1766             chip12=chip1*chip2
1767             alf1=alp(itypi)
1768             alf2=alp(itypj)
1769             alf12=0.5D0*(alf1+alf2)
1770 C For diagnostics only!!!
1771 c           chi1=0.0D0
1772 c           chi2=0.0D0
1773 c           chi12=0.0D0
1774 c           chip1=0.0D0
1775 c           chip2=0.0D0
1776 c           chip12=0.0D0
1777 c           alf1=0.0D0
1778 c           alf2=0.0D0
1779 c           alf12=0.0D0
1780             xj=c(1,nres+j)-xi
1781             yj=c(2,nres+j)-yi
1782             zj=c(3,nres+j)-zi
1783             dxj=dc_norm(1,nres+j)
1784             dyj=dc_norm(2,nres+j)
1785             dzj=dc_norm(3,nres+j)
1786             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1787             rij=dsqrt(rrij)
1788 C Calculate angle-dependent terms of energy and contributions to their
1789 C derivatives.
1790             call sc_angular
1791             sigsq=1.0D0/sigsq
1792             sig=sig0ij*dsqrt(sigsq)
1793             rij_shift=1.0D0/rij-sig+r0ij
1794 C I hate to put IF's in the loops, but here don't have another choice!!!!
1795             if (rij_shift.le.0.0D0) then
1796               evdw=1.0D20
1797               return
1798             endif
1799             sigder=-sig*sigsq
1800 c---------------------------------------------------------------
1801             rij_shift=1.0D0/rij_shift
1802             fac=rij_shift**expon
1803             e1=fac*fac*aa(itypi,itypj)
1804             e2=fac*bb(itypi,itypj)
1805             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1806             eps2der=evdwij*eps3rt
1807             eps3der=evdwij*eps2rt
1808             fac_augm=rrij**expon
1809             e_augm=augm(itypi,itypj)*fac_augm
1810             evdwij=evdwij*eps2rt*eps3rt
1811 #ifdef TSCSC
1812             if (bb(itypi,itypj).gt.0) then
1813                evdw_p=evdw_p+evdwij+e_augm
1814             else
1815                evdw_m=evdw_m+evdwij+e_augm
1816             endif
1817 #else
1818             evdw=evdw+evdwij+e_augm
1819 #endif
1820             if (lprn) then
1821             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1822             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1823             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1824      &        restyp(itypi),i,restyp(itypj),j,
1825      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1826      &        chi1,chi2,chip1,chip2,
1827      &        eps1,eps2rt**2,eps3rt**2,
1828      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1829      &        evdwij+e_augm
1830             endif
1831 C Calculate gradient components.
1832             e1=e1*eps1*eps2rt**2*eps3rt**2
1833             fac=-expon*(e1+evdwij)*rij_shift
1834             sigder=fac*sigder
1835             fac=rij*fac-2*expon*rrij*e_augm
1836 C Calculate the radial part of the gradient
1837             gg(1)=xj*fac
1838             gg(2)=yj*fac
1839             gg(3)=zj*fac
1840 C Calculate angular part of the gradient.
1841 #ifdef TSCSC
1842             if (bb(itypi,itypj).gt.0) then
1843                call sc_grad
1844             else
1845                call sc_grad_T
1846             endif
1847 #else
1848             call sc_grad
1849 #endif
1850           enddo      ! j
1851         enddo        ! iint
1852       enddo          ! i
1853       end
1854 C-----------------------------------------------------------------------------
1855       subroutine sc_angular
1856 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1857 C om12. Called by ebp, egb, and egbv.
1858       implicit none
1859       include 'COMMON.CALC'
1860       include 'COMMON.IOUNITS'
1861       erij(1)=xj*rij
1862       erij(2)=yj*rij
1863       erij(3)=zj*rij
1864       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1865       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1866       om12=dxi*dxj+dyi*dyj+dzi*dzj
1867       chiom12=chi12*om12
1868 C Calculate eps1(om12) and its derivative in om12
1869       faceps1=1.0D0-om12*chiom12
1870       faceps1_inv=1.0D0/faceps1
1871       eps1=dsqrt(faceps1_inv)
1872 C Following variable is eps1*deps1/dom12
1873       eps1_om12=faceps1_inv*chiom12
1874 c diagnostics only
1875 c      faceps1_inv=om12
1876 c      eps1=om12
1877 c      eps1_om12=1.0d0
1878 c      write (iout,*) "om12",om12," eps1",eps1
1879 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1880 C and om12.
1881       om1om2=om1*om2
1882       chiom1=chi1*om1
1883       chiom2=chi2*om2
1884       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1885       sigsq=1.0D0-facsig*faceps1_inv
1886       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1887       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1888       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1889 c diagnostics only
1890 c      sigsq=1.0d0
1891 c      sigsq_om1=0.0d0
1892 c      sigsq_om2=0.0d0
1893 c      sigsq_om12=0.0d0
1894 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1895 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1896 c     &    " eps1",eps1
1897 C Calculate eps2 and its derivatives in om1, om2, and om12.
1898       chipom1=chip1*om1
1899       chipom2=chip2*om2
1900       chipom12=chip12*om12
1901       facp=1.0D0-om12*chipom12
1902       facp_inv=1.0D0/facp
1903       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1904 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1905 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1906 C Following variable is the square root of eps2
1907       eps2rt=1.0D0-facp1*facp_inv
1908 C Following three variables are the derivatives of the square root of eps
1909 C in om1, om2, and om12.
1910       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1911       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1912       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1913 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1914       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1915 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1916 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1917 c     &  " eps2rt_om12",eps2rt_om12
1918 C Calculate whole angle-dependent part of epsilon and contributions
1919 C to its derivatives
1920       return
1921       end
1922
1923 C----------------------------------------------------------------------------
1924       subroutine sc_grad_T
1925       implicit real*8 (a-h,o-z)
1926       include 'DIMENSIONS'
1927       include 'COMMON.CHAIN'
1928       include 'COMMON.DERIV'
1929       include 'COMMON.CALC'
1930       include 'COMMON.IOUNITS'
1931       double precision dcosom1(3),dcosom2(3)
1932       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1933       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1934       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1935      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1936 c diagnostics only
1937 c      eom1=0.0d0
1938 c      eom2=0.0d0
1939 c      eom12=evdwij*eps1_om12
1940 c end diagnostics
1941 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1942 c     &  " sigder",sigder
1943 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1944 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1945       do k=1,3
1946         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1947         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1948       enddo
1949       do k=1,3
1950         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1951       enddo
1952 c      write (iout,*) "gg",(gg(k),k=1,3)
1953       do k=1,3
1954         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1955      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1956      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1957         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1958      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1959      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1960 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1961 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1962 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1963 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1964       enddo
1965 C
1966 C Calculate the components of the gradient in DC and X
1967 C
1968 cgrad      do k=i,j-1
1969 cgrad        do l=1,3
1970 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1971 cgrad        enddo
1972 cgrad      enddo
1973       do l=1,3
1974         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1975         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1976       enddo
1977       return
1978       end
1979
1980 C----------------------------------------------------------------------------
1981       subroutine sc_grad
1982       implicit real*8 (a-h,o-z)
1983       include 'DIMENSIONS'
1984       include 'COMMON.CHAIN'
1985       include 'COMMON.DERIV'
1986       include 'COMMON.CALC'
1987       include 'COMMON.IOUNITS'
1988       double precision dcosom1(3),dcosom2(3)
1989       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1990       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1991       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1992      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1993 c diagnostics only
1994 c      eom1=0.0d0
1995 c      eom2=0.0d0
1996 c      eom12=evdwij*eps1_om12
1997 c end diagnostics
1998 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1999 c     &  " sigder",sigder
2000 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2001 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2002       do k=1,3
2003         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2004         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2005       enddo
2006       do k=1,3
2007         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2008       enddo
2009 c      write (iout,*) "gg",(gg(k),k=1,3)
2010       do k=1,3
2011         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2012      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2013      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2014         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2015      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2016      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2017 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2018 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2019 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2020 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2021       enddo
2022 C
2023 C Calculate the components of the gradient in DC and X
2024 C
2025 cgrad      do k=i,j-1
2026 cgrad        do l=1,3
2027 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2028 cgrad        enddo
2029 cgrad      enddo
2030       do l=1,3
2031         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2032         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2033       enddo
2034       return
2035       end
2036 C-----------------------------------------------------------------------
2037       subroutine e_softsphere(evdw)
2038 C
2039 C This subroutine calculates the interaction energy of nonbonded side chains
2040 C assuming the LJ potential of interaction.
2041 C
2042       implicit real*8 (a-h,o-z)
2043       include 'DIMENSIONS'
2044       parameter (accur=1.0d-10)
2045       include 'COMMON.GEO'
2046       include 'COMMON.VAR'
2047       include 'COMMON.LOCAL'
2048       include 'COMMON.CHAIN'
2049       include 'COMMON.DERIV'
2050       include 'COMMON.INTERACT'
2051       include 'COMMON.TORSION'
2052       include 'COMMON.SBRIDGE'
2053       include 'COMMON.NAMES'
2054       include 'COMMON.IOUNITS'
2055       include 'COMMON.CONTACTS'
2056       dimension gg(3)
2057 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2058       evdw=0.0D0
2059       do i=iatsc_s,iatsc_e
2060         itypi=itype(i)
2061         itypi1=itype(i+1)
2062         xi=c(1,nres+i)
2063         yi=c(2,nres+i)
2064         zi=c(3,nres+i)
2065 C
2066 C Calculate SC interaction energy.
2067 C
2068         do iint=1,nint_gr(i)
2069 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2070 cd   &                  'iend=',iend(i,iint)
2071           do j=istart(i,iint),iend(i,iint)
2072             itypj=itype(j)
2073             xj=c(1,nres+j)-xi
2074             yj=c(2,nres+j)-yi
2075             zj=c(3,nres+j)-zi
2076             rij=xj*xj+yj*yj+zj*zj
2077 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2078             r0ij=r0(itypi,itypj)
2079             r0ijsq=r0ij*r0ij
2080 c            print *,i,j,r0ij,dsqrt(rij)
2081             if (rij.lt.r0ijsq) then
2082               evdwij=0.25d0*(rij-r0ijsq)**2
2083               fac=rij-r0ijsq
2084             else
2085               evdwij=0.0d0
2086               fac=0.0d0
2087             endif
2088             evdw=evdw+evdwij
2089 C
2090 C Calculate the components of the gradient in DC and X
2091 C
2092             gg(1)=xj*fac
2093             gg(2)=yj*fac
2094             gg(3)=zj*fac
2095             do k=1,3
2096               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2097               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2098               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2099               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2100             enddo
2101 cgrad            do k=i,j-1
2102 cgrad              do l=1,3
2103 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2104 cgrad              enddo
2105 cgrad            enddo
2106           enddo ! j
2107         enddo ! iint
2108       enddo ! i
2109       return
2110       end
2111 C--------------------------------------------------------------------------
2112       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2113      &              eello_turn4)
2114 C
2115 C Soft-sphere potential of p-p interaction
2116 C
2117       implicit real*8 (a-h,o-z)
2118       include 'DIMENSIONS'
2119       include 'COMMON.CONTROL'
2120       include 'COMMON.IOUNITS'
2121       include 'COMMON.GEO'
2122       include 'COMMON.VAR'
2123       include 'COMMON.LOCAL'
2124       include 'COMMON.CHAIN'
2125       include 'COMMON.DERIV'
2126       include 'COMMON.INTERACT'
2127       include 'COMMON.CONTACTS'
2128       include 'COMMON.TORSION'
2129       include 'COMMON.VECTORS'
2130       include 'COMMON.FFIELD'
2131       dimension ggg(3)
2132 cd      write(iout,*) 'In EELEC_soft_sphere'
2133       ees=0.0D0
2134       evdw1=0.0D0
2135       eel_loc=0.0d0
2136       eello_turn3=0.0d0
2137       eello_turn4=0.0d0
2138       ind=0
2139       do i=iatel_s,iatel_e
2140         dxi=dc(1,i)
2141         dyi=dc(2,i)
2142         dzi=dc(3,i)
2143         xmedi=c(1,i)+0.5d0*dxi
2144         ymedi=c(2,i)+0.5d0*dyi
2145         zmedi=c(3,i)+0.5d0*dzi
2146         num_conti=0
2147 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2148         do j=ielstart(i),ielend(i)
2149           ind=ind+1
2150           iteli=itel(i)
2151           itelj=itel(j)
2152           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2153           r0ij=rpp(iteli,itelj)
2154           r0ijsq=r0ij*r0ij
2155           dxj=dc(1,j)
2156           dyj=dc(2,j)
2157           dzj=dc(3,j)
2158           xj=c(1,j)+0.5D0*dxj-xmedi
2159           yj=c(2,j)+0.5D0*dyj-ymedi
2160           zj=c(3,j)+0.5D0*dzj-zmedi
2161           rij=xj*xj+yj*yj+zj*zj
2162           if (rij.lt.r0ijsq) then
2163             evdw1ij=0.25d0*(rij-r0ijsq)**2
2164             fac=rij-r0ijsq
2165           else
2166             evdw1ij=0.0d0
2167             fac=0.0d0
2168           endif
2169           evdw1=evdw1+evdw1ij
2170 C
2171 C Calculate contributions to the Cartesian gradient.
2172 C
2173           ggg(1)=fac*xj
2174           ggg(2)=fac*yj
2175           ggg(3)=fac*zj
2176           do k=1,3
2177             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2178             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2179           enddo
2180 *
2181 * Loop over residues i+1 thru j-1.
2182 *
2183 cgrad          do k=i+1,j-1
2184 cgrad            do l=1,3
2185 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2186 cgrad            enddo
2187 cgrad          enddo
2188         enddo ! j
2189       enddo   ! i
2190 cgrad      do i=nnt,nct-1
2191 cgrad        do k=1,3
2192 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2193 cgrad        enddo
2194 cgrad        do j=i+1,nct-1
2195 cgrad          do k=1,3
2196 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2197 cgrad          enddo
2198 cgrad        enddo
2199 cgrad      enddo
2200       return
2201       end
2202 c------------------------------------------------------------------------------
2203       subroutine vec_and_deriv
2204       implicit real*8 (a-h,o-z)
2205       include 'DIMENSIONS'
2206 #ifdef MPI
2207       include 'mpif.h'
2208 #endif
2209       include 'COMMON.IOUNITS'
2210       include 'COMMON.GEO'
2211       include 'COMMON.VAR'
2212       include 'COMMON.LOCAL'
2213       include 'COMMON.CHAIN'
2214       include 'COMMON.VECTORS'
2215       include 'COMMON.SETUP'
2216       include 'COMMON.TIME1'
2217       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2218 C Compute the local reference systems. For reference system (i), the
2219 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2220 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2221 #ifdef PARVEC
2222       do i=ivec_start,ivec_end
2223 #else
2224       do i=1,nres-1
2225 #endif
2226           if (i.eq.nres-1) then
2227 C Case of the last full residue
2228 C Compute the Z-axis
2229             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2230             costh=dcos(pi-theta(nres))
2231             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2232             do k=1,3
2233               uz(k,i)=fac*uz(k,i)
2234             enddo
2235 C Compute the derivatives of uz
2236             uzder(1,1,1)= 0.0d0
2237             uzder(2,1,1)=-dc_norm(3,i-1)
2238             uzder(3,1,1)= dc_norm(2,i-1)
2239             uzder(1,2,1)= dc_norm(3,i-1)
2240             uzder(2,2,1)= 0.0d0
2241             uzder(3,2,1)=-dc_norm(1,i-1)
2242             uzder(1,3,1)=-dc_norm(2,i-1)
2243             uzder(2,3,1)= dc_norm(1,i-1)
2244             uzder(3,3,1)= 0.0d0
2245             uzder(1,1,2)= 0.0d0
2246             uzder(2,1,2)= dc_norm(3,i)
2247             uzder(3,1,2)=-dc_norm(2,i)
2248             uzder(1,2,2)=-dc_norm(3,i)
2249             uzder(2,2,2)= 0.0d0
2250             uzder(3,2,2)= dc_norm(1,i)
2251             uzder(1,3,2)= dc_norm(2,i)
2252             uzder(2,3,2)=-dc_norm(1,i)
2253             uzder(3,3,2)= 0.0d0
2254 C Compute the Y-axis
2255             facy=fac
2256             do k=1,3
2257               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2258             enddo
2259 C Compute the derivatives of uy
2260             do j=1,3
2261               do k=1,3
2262                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2263      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2264                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2265               enddo
2266               uyder(j,j,1)=uyder(j,j,1)-costh
2267               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2268             enddo
2269             do j=1,2
2270               do k=1,3
2271                 do l=1,3
2272                   uygrad(l,k,j,i)=uyder(l,k,j)
2273                   uzgrad(l,k,j,i)=uzder(l,k,j)
2274                 enddo
2275               enddo
2276             enddo
2277             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2278             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2279             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2280             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2281           else
2282 C Other residues
2283 C Compute the Z-axis
2284             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2285             costh=dcos(pi-theta(i+2))
2286             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2287             do k=1,3
2288               uz(k,i)=fac*uz(k,i)
2289             enddo
2290 C Compute the derivatives of uz
2291             uzder(1,1,1)= 0.0d0
2292             uzder(2,1,1)=-dc_norm(3,i+1)
2293             uzder(3,1,1)= dc_norm(2,i+1)
2294             uzder(1,2,1)= dc_norm(3,i+1)
2295             uzder(2,2,1)= 0.0d0
2296             uzder(3,2,1)=-dc_norm(1,i+1)
2297             uzder(1,3,1)=-dc_norm(2,i+1)
2298             uzder(2,3,1)= dc_norm(1,i+1)
2299             uzder(3,3,1)= 0.0d0
2300             uzder(1,1,2)= 0.0d0
2301             uzder(2,1,2)= dc_norm(3,i)
2302             uzder(3,1,2)=-dc_norm(2,i)
2303             uzder(1,2,2)=-dc_norm(3,i)
2304             uzder(2,2,2)= 0.0d0
2305             uzder(3,2,2)= dc_norm(1,i)
2306             uzder(1,3,2)= dc_norm(2,i)
2307             uzder(2,3,2)=-dc_norm(1,i)
2308             uzder(3,3,2)= 0.0d0
2309 C Compute the Y-axis
2310             facy=fac
2311             do k=1,3
2312               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2313             enddo
2314 C Compute the derivatives of uy
2315             do j=1,3
2316               do k=1,3
2317                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2318      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2319                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2320               enddo
2321               uyder(j,j,1)=uyder(j,j,1)-costh
2322               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2323             enddo
2324             do j=1,2
2325               do k=1,3
2326                 do l=1,3
2327                   uygrad(l,k,j,i)=uyder(l,k,j)
2328                   uzgrad(l,k,j,i)=uzder(l,k,j)
2329                 enddo
2330               enddo
2331             enddo
2332             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2333             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2334             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2335             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2336           endif
2337       enddo
2338       do i=1,nres-1
2339         vbld_inv_temp(1)=vbld_inv(i+1)
2340         if (i.lt.nres-1) then
2341           vbld_inv_temp(2)=vbld_inv(i+2)
2342           else
2343           vbld_inv_temp(2)=vbld_inv(i)
2344           endif
2345         do j=1,2
2346           do k=1,3
2347             do l=1,3
2348               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2349               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2350             enddo
2351           enddo
2352         enddo
2353       enddo
2354 #if defined(PARVEC) && defined(MPI)
2355       if (nfgtasks1.gt.1) then
2356         time00=MPI_Wtime()
2357 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2358 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2359 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2360         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2361      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2362      &   FG_COMM1,IERR)
2363         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2364      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2365      &   FG_COMM1,IERR)
2366         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2367      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2368      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2369         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2370      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2371      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2372         time_gather=time_gather+MPI_Wtime()-time00
2373       endif
2374 c      if (fg_rank.eq.0) then
2375 c        write (iout,*) "Arrays UY and UZ"
2376 c        do i=1,nres-1
2377 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2378 c     &     (uz(k,i),k=1,3)
2379 c        enddo
2380 c      endif
2381 #endif
2382       return
2383       end
2384 C-----------------------------------------------------------------------------
2385       subroutine check_vecgrad
2386       implicit real*8 (a-h,o-z)
2387       include 'DIMENSIONS'
2388       include 'COMMON.IOUNITS'
2389       include 'COMMON.GEO'
2390       include 'COMMON.VAR'
2391       include 'COMMON.LOCAL'
2392       include 'COMMON.CHAIN'
2393       include 'COMMON.VECTORS'
2394       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2395       dimension uyt(3,maxres),uzt(3,maxres)
2396       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2397       double precision delta /1.0d-7/
2398       call vec_and_deriv
2399 cd      do i=1,nres
2400 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2401 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2402 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2403 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2404 cd     &     (dc_norm(if90,i),if90=1,3)
2405 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2406 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2407 cd          write(iout,'(a)')
2408 cd      enddo
2409       do i=1,nres
2410         do j=1,2
2411           do k=1,3
2412             do l=1,3
2413               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2414               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2415             enddo
2416           enddo
2417         enddo
2418       enddo
2419       call vec_and_deriv
2420       do i=1,nres
2421         do j=1,3
2422           uyt(j,i)=uy(j,i)
2423           uzt(j,i)=uz(j,i)
2424         enddo
2425       enddo
2426       do i=1,nres
2427 cd        write (iout,*) 'i=',i
2428         do k=1,3
2429           erij(k)=dc_norm(k,i)
2430         enddo
2431         do j=1,3
2432           do k=1,3
2433             dc_norm(k,i)=erij(k)
2434           enddo
2435           dc_norm(j,i)=dc_norm(j,i)+delta
2436 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2437 c          do k=1,3
2438 c            dc_norm(k,i)=dc_norm(k,i)/fac
2439 c          enddo
2440 c          write (iout,*) (dc_norm(k,i),k=1,3)
2441 c          write (iout,*) (erij(k),k=1,3)
2442           call vec_and_deriv
2443           do k=1,3
2444             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2445             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2446             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2447             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2448           enddo
2449 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2450 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2451 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2452         enddo
2453         do k=1,3
2454           dc_norm(k,i)=erij(k)
2455         enddo
2456 cd        do k=1,3
2457 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2458 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2459 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2460 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2461 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2462 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2463 cd          write (iout,'(a)')
2464 cd        enddo
2465       enddo
2466       return
2467       end
2468 C--------------------------------------------------------------------------
2469       subroutine set_matrices
2470       implicit real*8 (a-h,o-z)
2471       include 'DIMENSIONS'
2472 #ifdef MPI
2473       include "mpif.h"
2474       include "COMMON.SETUP"
2475       integer IERR
2476       integer status(MPI_STATUS_SIZE)
2477 #endif
2478       include 'COMMON.IOUNITS'
2479       include 'COMMON.GEO'
2480       include 'COMMON.VAR'
2481       include 'COMMON.LOCAL'
2482       include 'COMMON.CHAIN'
2483       include 'COMMON.DERIV'
2484       include 'COMMON.INTERACT'
2485       include 'COMMON.CONTACTS'
2486       include 'COMMON.TORSION'
2487       include 'COMMON.VECTORS'
2488       include 'COMMON.FFIELD'
2489       double precision auxvec(2),auxmat(2,2)
2490 C
2491 C Compute the virtual-bond-torsional-angle dependent quantities needed
2492 C to calculate the el-loc multibody terms of various order.
2493 C
2494 #ifdef PARMAT
2495       do i=ivec_start+2,ivec_end+2
2496 #else
2497       do i=3,nres+1
2498 #endif
2499         if (i .lt. nres+1) then
2500           sin1=dsin(phi(i))
2501           cos1=dcos(phi(i))
2502           sintab(i-2)=sin1
2503           costab(i-2)=cos1
2504           obrot(1,i-2)=cos1
2505           obrot(2,i-2)=sin1
2506           sin2=dsin(2*phi(i))
2507           cos2=dcos(2*phi(i))
2508           sintab2(i-2)=sin2
2509           costab2(i-2)=cos2
2510           obrot2(1,i-2)=cos2
2511           obrot2(2,i-2)=sin2
2512           Ug(1,1,i-2)=-cos1
2513           Ug(1,2,i-2)=-sin1
2514           Ug(2,1,i-2)=-sin1
2515           Ug(2,2,i-2)= cos1
2516           Ug2(1,1,i-2)=-cos2
2517           Ug2(1,2,i-2)=-sin2
2518           Ug2(2,1,i-2)=-sin2
2519           Ug2(2,2,i-2)= cos2
2520         else
2521           costab(i-2)=1.0d0
2522           sintab(i-2)=0.0d0
2523           obrot(1,i-2)=1.0d0
2524           obrot(2,i-2)=0.0d0
2525           obrot2(1,i-2)=0.0d0
2526           obrot2(2,i-2)=0.0d0
2527           Ug(1,1,i-2)=1.0d0
2528           Ug(1,2,i-2)=0.0d0
2529           Ug(2,1,i-2)=0.0d0
2530           Ug(2,2,i-2)=1.0d0
2531           Ug2(1,1,i-2)=0.0d0
2532           Ug2(1,2,i-2)=0.0d0
2533           Ug2(2,1,i-2)=0.0d0
2534           Ug2(2,2,i-2)=0.0d0
2535         endif
2536         if (i .gt. 3 .and. i .lt. nres+1) then
2537           obrot_der(1,i-2)=-sin1
2538           obrot_der(2,i-2)= cos1
2539           Ugder(1,1,i-2)= sin1
2540           Ugder(1,2,i-2)=-cos1
2541           Ugder(2,1,i-2)=-cos1
2542           Ugder(2,2,i-2)=-sin1
2543           dwacos2=cos2+cos2
2544           dwasin2=sin2+sin2
2545           obrot2_der(1,i-2)=-dwasin2
2546           obrot2_der(2,i-2)= dwacos2
2547           Ug2der(1,1,i-2)= dwasin2
2548           Ug2der(1,2,i-2)=-dwacos2
2549           Ug2der(2,1,i-2)=-dwacos2
2550           Ug2der(2,2,i-2)=-dwasin2
2551         else
2552           obrot_der(1,i-2)=0.0d0
2553           obrot_der(2,i-2)=0.0d0
2554           Ugder(1,1,i-2)=0.0d0
2555           Ugder(1,2,i-2)=0.0d0
2556           Ugder(2,1,i-2)=0.0d0
2557           Ugder(2,2,i-2)=0.0d0
2558           obrot2_der(1,i-2)=0.0d0
2559           obrot2_der(2,i-2)=0.0d0
2560           Ug2der(1,1,i-2)=0.0d0
2561           Ug2der(1,2,i-2)=0.0d0
2562           Ug2der(2,1,i-2)=0.0d0
2563           Ug2der(2,2,i-2)=0.0d0
2564         endif
2565 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2566         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2567           iti = itortyp(itype(i-2))
2568         else
2569           iti=ntortyp+1
2570         endif
2571 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2572         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2573           iti1 = itortyp(itype(i-1))
2574         else
2575           iti1=ntortyp+1
2576         endif
2577 cd        write (iout,*) '*******i',i,' iti1',iti
2578 cd        write (iout,*) 'b1',b1(:,iti)
2579 cd        write (iout,*) 'b2',b2(:,iti)
2580 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2581 c        if (i .gt. iatel_s+2) then
2582         if (i .gt. nnt+2) then
2583           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2584           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,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,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2588           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2589           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2590           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2591           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2592           endif
2593         else
2594           do k=1,2
2595             Ub2(k,i-2)=0.0d0
2596             Ctobr(k,i-2)=0.0d0
2597             Dtobr2(k,i-2)=0.0d0
2598             do l=1,2
2599               EUg(l,k,i-2)=0.0d0
2600               CUg(l,k,i-2)=0.0d0
2601               DUg(l,k,i-2)=0.0d0
2602               DtUg2(l,k,i-2)=0.0d0
2603             enddo
2604           enddo
2605         endif
2606         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2607         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2608         do k=1,2
2609           muder(k,i-2)=Ub2der(k,i-2)
2610         enddo
2611 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2612         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2613           iti1 = itortyp(itype(i-1))
2614         else
2615           iti1=ntortyp+1
2616         endif
2617         do k=1,2
2618           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2619         enddo
2620 cd        write (iout,*) 'mu ',mu(:,i-2)
2621 cd        write (iout,*) 'mu1',mu1(:,i-2)
2622 cd        write (iout,*) 'mu2',mu2(:,i-2)
2623         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2624      &  then
2625         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2626         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2627         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2628         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2629         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2630 C Vectors and matrices dependent on a single virtual-bond dihedral.
2631         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2632         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2633         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2634         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2635         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2636         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2637         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2638         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2639         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2640         endif
2641       enddo
2642 C Matrices dependent on two consecutive virtual-bond dihedrals.
2643 C The order of matrices is from left to right.
2644       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2645      &then
2646 c      do i=max0(ivec_start,2),ivec_end
2647       do i=2,nres-1
2648         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2649         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2650         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2651         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2652         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2653         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2654         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2655         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2656       enddo
2657       endif
2658 #if defined(MPI) && defined(PARMAT)
2659 #ifdef DEBUG
2660 c      if (fg_rank.eq.0) then
2661         write (iout,*) "Arrays UG and UGDER before GATHER"
2662         do i=1,nres-1
2663           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2664      &     ((ug(l,k,i),l=1,2),k=1,2),
2665      &     ((ugder(l,k,i),l=1,2),k=1,2)
2666         enddo
2667         write (iout,*) "Arrays UG2 and UG2DER"
2668         do i=1,nres-1
2669           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2670      &     ((ug2(l,k,i),l=1,2),k=1,2),
2671      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2672         enddo
2673         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2674         do i=1,nres-1
2675           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2676      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2677      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2678         enddo
2679         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2680         do i=1,nres-1
2681           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2682      &     costab(i),sintab(i),costab2(i),sintab2(i)
2683         enddo
2684         write (iout,*) "Array MUDER"
2685         do i=1,nres-1
2686           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2687         enddo
2688 c      endif
2689 #endif
2690       if (nfgtasks.gt.1) then
2691         time00=MPI_Wtime()
2692 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2693 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2694 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2695 #ifdef MATGATHER
2696         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2697      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2698      &   FG_COMM1,IERR)
2699         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2700      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2701      &   FG_COMM1,IERR)
2702         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2703      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2704      &   FG_COMM1,IERR)
2705         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2706      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2707      &   FG_COMM1,IERR)
2708         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2709      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2710      &   FG_COMM1,IERR)
2711         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2712      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2713      &   FG_COMM1,IERR)
2714         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2715      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2716      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2717         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2718      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2719      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2720         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2721      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2722      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2723         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2724      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2725      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2726         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2727      &  then
2728         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2729      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2730      &   FG_COMM1,IERR)
2731         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2732      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2733      &   FG_COMM1,IERR)
2734         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2735      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2736      &   FG_COMM1,IERR)
2737        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2738      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2739      &   FG_COMM1,IERR)
2740         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2741      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2742      &   FG_COMM1,IERR)
2743         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2744      &   ivec_count(fg_rank1),
2745      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2746      &   FG_COMM1,IERR)
2747         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2748      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2749      &   FG_COMM1,IERR)
2750         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2751      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2752      &   FG_COMM1,IERR)
2753         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2754      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2755      &   FG_COMM1,IERR)
2756         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2757      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2758      &   FG_COMM1,IERR)
2759         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2760      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2761      &   FG_COMM1,IERR)
2762         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2763      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2764      &   FG_COMM1,IERR)
2765         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2766      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2767      &   FG_COMM1,IERR)
2768         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2769      &   ivec_count(fg_rank1),
2770      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2771      &   FG_COMM1,IERR)
2772         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2773      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2774      &   FG_COMM1,IERR)
2775        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2776      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2777      &   FG_COMM1,IERR)
2778         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2779      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2780      &   FG_COMM1,IERR)
2781        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2782      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2783      &   FG_COMM1,IERR)
2784         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2785      &   ivec_count(fg_rank1),
2786      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2787      &   FG_COMM1,IERR)
2788         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2789      &   ivec_count(fg_rank1),
2790      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2791      &   FG_COMM1,IERR)
2792         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2793      &   ivec_count(fg_rank1),
2794      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2795      &   MPI_MAT2,FG_COMM1,IERR)
2796         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2797      &   ivec_count(fg_rank1),
2798      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2799      &   MPI_MAT2,FG_COMM1,IERR)
2800         endif
2801 #else
2802 c Passes matrix info through the ring
2803       isend=fg_rank1
2804       irecv=fg_rank1-1
2805       if (irecv.lt.0) irecv=nfgtasks1-1
2806       iprev=irecv
2807       inext=fg_rank1+1
2808       if (inext.ge.nfgtasks1) inext=0
2809       do i=1,nfgtasks1-1
2810 c        write (iout,*) "isend",isend," irecv",irecv
2811 c        call flush(iout)
2812         lensend=lentyp(isend)
2813         lenrecv=lentyp(irecv)
2814 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2815 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2816 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2817 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2818 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2819 c        write (iout,*) "Gather ROTAT1"
2820 c        call flush(iout)
2821 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2822 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2823 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2824 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2825 c        write (iout,*) "Gather ROTAT2"
2826 c        call flush(iout)
2827         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2828      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2829      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2830      &   iprev,4400+irecv,FG_COMM,status,IERR)
2831 c        write (iout,*) "Gather ROTAT_OLD"
2832 c        call flush(iout)
2833         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2834      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2835      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2836      &   iprev,5500+irecv,FG_COMM,status,IERR)
2837 c        write (iout,*) "Gather PRECOMP11"
2838 c        call flush(iout)
2839         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2840      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2841      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2842      &   iprev,6600+irecv,FG_COMM,status,IERR)
2843 c        write (iout,*) "Gather PRECOMP12"
2844 c        call flush(iout)
2845         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2846      &  then
2847         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2848      &   MPI_ROTAT2(lensend),inext,7700+isend,
2849      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2850      &   iprev,7700+irecv,FG_COMM,status,IERR)
2851 c        write (iout,*) "Gather PRECOMP21"
2852 c        call flush(iout)
2853         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2854      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2855      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2856      &   iprev,8800+irecv,FG_COMM,status,IERR)
2857 c        write (iout,*) "Gather PRECOMP22"
2858 c        call flush(iout)
2859         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2860      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2861      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2862      &   MPI_PRECOMP23(lenrecv),
2863      &   iprev,9900+irecv,FG_COMM,status,IERR)
2864 c        write (iout,*) "Gather PRECOMP23"
2865 c        call flush(iout)
2866         endif
2867         isend=irecv
2868         irecv=irecv-1
2869         if (irecv.lt.0) irecv=nfgtasks1-1
2870       enddo
2871 #endif
2872         time_gather=time_gather+MPI_Wtime()-time00
2873       endif
2874 #ifdef DEBUG
2875 c      if (fg_rank.eq.0) then
2876         write (iout,*) "Arrays UG and UGDER"
2877         do i=1,nres-1
2878           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2879      &     ((ug(l,k,i),l=1,2),k=1,2),
2880      &     ((ugder(l,k,i),l=1,2),k=1,2)
2881         enddo
2882         write (iout,*) "Arrays UG2 and UG2DER"
2883         do i=1,nres-1
2884           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2885      &     ((ug2(l,k,i),l=1,2),k=1,2),
2886      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2887         enddo
2888         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2889         do i=1,nres-1
2890           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2891      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2892      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2893         enddo
2894         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2895         do i=1,nres-1
2896           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2897      &     costab(i),sintab(i),costab2(i),sintab2(i)
2898         enddo
2899         write (iout,*) "Array MUDER"
2900         do i=1,nres-1
2901           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2902         enddo
2903 c      endif
2904 #endif
2905 #endif
2906 cd      do i=1,nres
2907 cd        iti = itortyp(itype(i))
2908 cd        write (iout,*) i
2909 cd        do j=1,2
2910 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2911 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2912 cd        enddo
2913 cd      enddo
2914       return
2915       end
2916 C--------------------------------------------------------------------------
2917       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2918 C
2919 C This subroutine calculates the average interaction energy and its gradient
2920 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2921 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2922 C The potential depends both on the distance of peptide-group centers and on
2923 C the orientation of the CA-CA virtual bonds.
2924 C
2925       implicit real*8 (a-h,o-z)
2926 #ifdef MPI
2927       include 'mpif.h'
2928 #endif
2929       include 'DIMENSIONS'
2930       include 'COMMON.CONTROL'
2931       include 'COMMON.SETUP'
2932       include 'COMMON.IOUNITS'
2933       include 'COMMON.GEO'
2934       include 'COMMON.VAR'
2935       include 'COMMON.LOCAL'
2936       include 'COMMON.CHAIN'
2937       include 'COMMON.DERIV'
2938       include 'COMMON.INTERACT'
2939       include 'COMMON.CONTACTS'
2940       include 'COMMON.TORSION'
2941       include 'COMMON.VECTORS'
2942       include 'COMMON.FFIELD'
2943       include 'COMMON.TIME1'
2944       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2945      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2946       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2947      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2948       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2949      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2950      &    num_conti,j1,j2
2951 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2952 #ifdef MOMENT
2953       double precision scal_el /1.0d0/
2954 #else
2955       double precision scal_el /0.5d0/
2956 #endif
2957 C 12/13/98
2958 C 13-go grudnia roku pamietnego...
2959       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2960      &                   0.0d0,1.0d0,0.0d0,
2961      &                   0.0d0,0.0d0,1.0d0/
2962 cd      write(iout,*) 'In EELEC'
2963 cd      do i=1,nloctyp
2964 cd        write(iout,*) 'Type',i
2965 cd        write(iout,*) 'B1',B1(:,i)
2966 cd        write(iout,*) 'B2',B2(:,i)
2967 cd        write(iout,*) 'CC',CC(:,:,i)
2968 cd        write(iout,*) 'DD',DD(:,:,i)
2969 cd        write(iout,*) 'EE',EE(:,:,i)
2970 cd      enddo
2971 cd      call check_vecgrad
2972 cd      stop
2973       if (icheckgrad.eq.1) then
2974         do i=1,nres-1
2975           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2976           do k=1,3
2977             dc_norm(k,i)=dc(k,i)*fac
2978           enddo
2979 c          write (iout,*) 'i',i,' fac',fac
2980         enddo
2981       endif
2982       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2983      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2984      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2985 c        call vec_and_deriv
2986 #ifdef TIMING
2987         time01=MPI_Wtime()
2988 #endif
2989         call set_matrices
2990 #ifdef TIMING
2991         time_mat=time_mat+MPI_Wtime()-time01
2992 #endif
2993       endif
2994 cd      do i=1,nres-1
2995 cd        write (iout,*) 'i=',i
2996 cd        do k=1,3
2997 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2998 cd        enddo
2999 cd        do k=1,3
3000 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3001 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3002 cd        enddo
3003 cd      enddo
3004       t_eelecij=0.0d0
3005       ees=0.0D0
3006       evdw1=0.0D0
3007       eel_loc=0.0d0
3008       eello_turn3=0.0d0
3009       eello_turn4=0.0d0
3010       ind=0
3011       do i=1,nres
3012         num_cont_hb(i)=0
3013       enddo
3014 cd      print '(a)','Enter EELEC'
3015 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3016       do i=1,nres
3017         gel_loc_loc(i)=0.0d0
3018         gcorr_loc(i)=0.0d0
3019       enddo
3020 c
3021 c
3022 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3023 C
3024 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3025 C
3026       do i=iturn3_start,iturn3_end
3027 C        if (itype(i).eq.21 .or. itype(i+1).eq.21
3028 C     &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21.or.itype(i+4).eq.21)
3029 C     &  cycle
3030         dxi=dc(1,i)
3031         dyi=dc(2,i)
3032         dzi=dc(3,i)
3033         dx_normi=dc_norm(1,i)
3034         dy_normi=dc_norm(2,i)
3035         dz_normi=dc_norm(3,i)
3036         xmedi=c(1,i)+0.5d0*dxi
3037         ymedi=c(2,i)+0.5d0*dyi
3038         zmedi=c(3,i)+0.5d0*dzi
3039         num_conti=0
3040         call eelecij(i,i+2,ees,evdw1,eel_loc)
3041         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3042         num_cont_hb(i)=num_conti
3043       enddo
3044       do i=iturn4_start,iturn4_end
3045 C        if (itype(i).eq.21 .or. itype(i+1).eq.21
3046 C     &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21.or.itype(i+4).eq.21
3047 C     &  .or. itype(i+5).eq.21)
3048 C     & cycle
3049         dxi=dc(1,i)
3050         dyi=dc(2,i)
3051         dzi=dc(3,i)
3052         dx_normi=dc_norm(1,i)
3053         dy_normi=dc_norm(2,i)
3054         dz_normi=dc_norm(3,i)
3055         xmedi=c(1,i)+0.5d0*dxi
3056         ymedi=c(2,i)+0.5d0*dyi
3057         zmedi=c(3,i)+0.5d0*dzi
3058         num_conti=num_cont_hb(i)
3059         call eelecij(i,i+3,ees,evdw1,eel_loc)
3060         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3061         num_cont_hb(i)=num_conti
3062       enddo   ! i
3063 c
3064 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3065 c
3066       do i=iatel_s,iatel_e
3067 C          if (itype(i).eq.21 .or. itype(i+1).eq.21
3068 C     &.or.itype(i+2)) cycle
3069         dxi=dc(1,i)
3070         dyi=dc(2,i)
3071         dzi=dc(3,i)
3072         dx_normi=dc_norm(1,i)
3073         dy_normi=dc_norm(2,i)
3074         dz_normi=dc_norm(3,i)
3075         xmedi=c(1,i)+0.5d0*dxi
3076         ymedi=c(2,i)+0.5d0*dyi
3077         zmedi=c(3,i)+0.5d0*dzi
3078 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3079         num_conti=num_cont_hb(i)
3080         do j=ielstart(i),ielend(i)
3081 C          if (itype(j).eq.21 .or. itype(j+1).eq.21
3082 C     &.or.itype(j+2)) cycle
3083           call eelecij(i,j,ees,evdw1,eel_loc)
3084         enddo ! j
3085         num_cont_hb(i)=num_conti
3086       enddo   ! i
3087 c      write (iout,*) "Number of loop steps in EELEC:",ind
3088 cd      do i=1,nres
3089 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3090 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3091 cd      enddo
3092 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3093 ccc      eel_loc=eel_loc+eello_turn3
3094 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3095       return
3096       end
3097 C-------------------------------------------------------------------------------
3098       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3099       implicit real*8 (a-h,o-z)
3100       include 'DIMENSIONS'
3101 #ifdef MPI
3102       include "mpif.h"
3103 #endif
3104       include 'COMMON.CONTROL'
3105       include 'COMMON.IOUNITS'
3106       include 'COMMON.GEO'
3107       include 'COMMON.VAR'
3108       include 'COMMON.LOCAL'
3109       include 'COMMON.CHAIN'
3110       include 'COMMON.DERIV'
3111       include 'COMMON.INTERACT'
3112       include 'COMMON.CONTACTS'
3113       include 'COMMON.TORSION'
3114       include 'COMMON.VECTORS'
3115       include 'COMMON.FFIELD'
3116       include 'COMMON.TIME1'
3117       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3118      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3119       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3120      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3121       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3122      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3123      &    num_conti,j1,j2
3124 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3125 #ifdef MOMENT
3126       double precision scal_el /1.0d0/
3127 #else
3128       double precision scal_el /0.5d0/
3129 #endif
3130 C 12/13/98
3131 C 13-go grudnia roku pamietnego...
3132       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3133      &                   0.0d0,1.0d0,0.0d0,
3134      &                   0.0d0,0.0d0,1.0d0/
3135 c          time00=MPI_Wtime()
3136 cd      write (iout,*) "eelecij",i,j
3137 c          ind=ind+1
3138           iteli=itel(i)
3139           itelj=itel(j)
3140           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3141           aaa=app(iteli,itelj)
3142           bbb=bpp(iteli,itelj)
3143           ael6i=ael6(iteli,itelj)
3144           ael3i=ael3(iteli,itelj)
3145           dxj=dc(1,j)
3146           dyj=dc(2,j)
3147           dzj=dc(3,j)
3148           dx_normj=dc_norm(1,j)
3149           dy_normj=dc_norm(2,j)
3150           dz_normj=dc_norm(3,j)
3151           xj=c(1,j)+0.5D0*dxj-xmedi
3152           yj=c(2,j)+0.5D0*dyj-ymedi
3153           zj=c(3,j)+0.5D0*dzj-zmedi
3154           rij=xj*xj+yj*yj+zj*zj
3155           rrmij=1.0D0/rij
3156           rij=dsqrt(rij)
3157           rmij=1.0D0/rij
3158           r3ij=rrmij*rmij
3159           r6ij=r3ij*r3ij
3160           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3161           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3162           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3163           fac=cosa-3.0D0*cosb*cosg
3164           ev1=aaa*r6ij*r6ij
3165 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3166           if (j.eq.i+2) ev1=scal_el*ev1
3167           ev2=bbb*r6ij
3168           fac3=ael6i*r6ij
3169           fac4=ael3i*r3ij
3170           evdwij=ev1+ev2
3171           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3172           el2=fac4*fac
3173           eesij=el1+el2
3174 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3175           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3176           ees=ees+eesij
3177           evdw1=evdw1+evdwij
3178 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3179 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3180 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3181 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3182
3183           if (energy_dec) then
3184               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3185               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3186           endif
3187
3188 C
3189 C Calculate contributions to the Cartesian gradient.
3190 C
3191 #ifdef SPLITELE
3192           facvdw=-6*rrmij*(ev1+evdwij)
3193           facel=-3*rrmij*(el1+eesij)
3194           fac1=fac
3195           erij(1)=xj*rmij
3196           erij(2)=yj*rmij
3197           erij(3)=zj*rmij
3198 *
3199 * Radial derivatives. First process both termini of the fragment (i,j)
3200 *
3201           ggg(1)=facel*xj
3202           ggg(2)=facel*yj
3203           ggg(3)=facel*zj
3204 c          do k=1,3
3205 c            ghalf=0.5D0*ggg(k)
3206 c            gelc(k,i)=gelc(k,i)+ghalf
3207 c            gelc(k,j)=gelc(k,j)+ghalf
3208 c          enddo
3209 c 9/28/08 AL Gradient compotents will be summed only at the end
3210           do k=1,3
3211             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3212             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3213           enddo
3214 *
3215 * Loop over residues i+1 thru j-1.
3216 *
3217 cgrad          do k=i+1,j-1
3218 cgrad            do l=1,3
3219 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3220 cgrad            enddo
3221 cgrad          enddo
3222           ggg(1)=facvdw*xj
3223           ggg(2)=facvdw*yj
3224           ggg(3)=facvdw*zj
3225 c          do k=1,3
3226 c            ghalf=0.5D0*ggg(k)
3227 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3228 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3229 c          enddo
3230 c 9/28/08 AL Gradient compotents will be summed only at the end
3231           do k=1,3
3232             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3233             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3234           enddo
3235 *
3236 * Loop over residues i+1 thru j-1.
3237 *
3238 cgrad          do k=i+1,j-1
3239 cgrad            do l=1,3
3240 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3241 cgrad            enddo
3242 cgrad          enddo
3243 #else
3244           facvdw=ev1+evdwij
3245           facel=el1+eesij
3246           fac1=fac
3247           fac=-3*rrmij*(facvdw+facvdw+facel)
3248           erij(1)=xj*rmij
3249           erij(2)=yj*rmij
3250           erij(3)=zj*rmij
3251 *
3252 * Radial derivatives. First process both termini of the fragment (i,j)
3253 *
3254           ggg(1)=fac*xj
3255           ggg(2)=fac*yj
3256           ggg(3)=fac*zj
3257 c          do k=1,3
3258 c            ghalf=0.5D0*ggg(k)
3259 c            gelc(k,i)=gelc(k,i)+ghalf
3260 c            gelc(k,j)=gelc(k,j)+ghalf
3261 c          enddo
3262 c 9/28/08 AL Gradient compotents will be summed only at the end
3263           do k=1,3
3264             gelc_long(k,j)=gelc(k,j)+ggg(k)
3265             gelc_long(k,i)=gelc(k,i)-ggg(k)
3266           enddo
3267 *
3268 * Loop over residues i+1 thru j-1.
3269 *
3270 cgrad          do k=i+1,j-1
3271 cgrad            do l=1,3
3272 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3273 cgrad            enddo
3274 cgrad          enddo
3275 c 9/28/08 AL Gradient compotents will be summed only at the end
3276           ggg(1)=facvdw*xj
3277           ggg(2)=facvdw*yj
3278           ggg(3)=facvdw*zj
3279           do k=1,3
3280             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3281             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3282           enddo
3283 #endif
3284 *
3285 * Angular part
3286 *
3287           ecosa=2.0D0*fac3*fac1+fac4
3288           fac4=-3.0D0*fac4
3289           fac3=-6.0D0*fac3
3290           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3291           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3292           do k=1,3
3293             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3294             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3295           enddo
3296 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3297 cd   &          (dcosg(k),k=1,3)
3298           do k=1,3
3299             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3300           enddo
3301 c          do k=1,3
3302 c            ghalf=0.5D0*ggg(k)
3303 c            gelc(k,i)=gelc(k,i)+ghalf
3304 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3305 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3306 c            gelc(k,j)=gelc(k,j)+ghalf
3307 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3308 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3309 c          enddo
3310 cgrad          do k=i+1,j-1
3311 cgrad            do l=1,3
3312 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3313 cgrad            enddo
3314 cgrad          enddo
3315           do k=1,3
3316             gelc(k,i)=gelc(k,i)
3317      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3318      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3319             gelc(k,j)=gelc(k,j)
3320      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3321      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3322             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3323             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3324           enddo
3325           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3326      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3327      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3328 C
3329 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3330 C   energy of a peptide unit is assumed in the form of a second-order
3331 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3332 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3333 C   are computed for EVERY pair of non-contiguous peptide groups.
3334 C
3335           if (j.lt.nres-1) then
3336             j1=j+1
3337             j2=j-1
3338           else
3339             j1=j-1
3340             j2=j-2
3341           endif
3342           kkk=0
3343           do k=1,2
3344             do l=1,2
3345               kkk=kkk+1
3346               muij(kkk)=mu(k,i)*mu(l,j)
3347             enddo
3348           enddo
3349 cd         write (iout,*) 'EELEC: i',i,' j',j
3350 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3351 cd          write(iout,*) 'muij',muij
3352           ury=scalar(uy(1,i),erij)
3353           urz=scalar(uz(1,i),erij)
3354           vry=scalar(uy(1,j),erij)
3355           vrz=scalar(uz(1,j),erij)
3356           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3357           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3358           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3359           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3360           fac=dsqrt(-ael6i)*r3ij
3361           a22=a22*fac
3362           a23=a23*fac
3363           a32=a32*fac
3364           a33=a33*fac
3365 cd          write (iout,'(4i5,4f10.5)')
3366 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3367 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3368 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3369 cd     &      uy(:,j),uz(:,j)
3370 cd          write (iout,'(4f10.5)')
3371 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3372 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3373 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3374 cd           write (iout,'(9f10.5/)')
3375 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3376 C Derivatives of the elements of A in virtual-bond vectors
3377           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3378           do k=1,3
3379             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3380             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3381             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3382             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3383             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3384             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3385             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3386             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3387             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3388             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3389             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3390             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3391           enddo
3392 C Compute radial contributions to the gradient
3393           facr=-3.0d0*rrmij
3394           a22der=a22*facr
3395           a23der=a23*facr
3396           a32der=a32*facr
3397           a33der=a33*facr
3398           agg(1,1)=a22der*xj
3399           agg(2,1)=a22der*yj
3400           agg(3,1)=a22der*zj
3401           agg(1,2)=a23der*xj
3402           agg(2,2)=a23der*yj
3403           agg(3,2)=a23der*zj
3404           agg(1,3)=a32der*xj
3405           agg(2,3)=a32der*yj
3406           agg(3,3)=a32der*zj
3407           agg(1,4)=a33der*xj
3408           agg(2,4)=a33der*yj
3409           agg(3,4)=a33der*zj
3410 C Add the contributions coming from er
3411           fac3=-3.0d0*fac
3412           do k=1,3
3413             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3414             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3415             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3416             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3417           enddo
3418           do k=1,3
3419 C Derivatives in DC(i)
3420 cgrad            ghalf1=0.5d0*agg(k,1)
3421 cgrad            ghalf2=0.5d0*agg(k,2)
3422 cgrad            ghalf3=0.5d0*agg(k,3)
3423 cgrad            ghalf4=0.5d0*agg(k,4)
3424             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3425      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3426             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3427      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3428             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3429      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3430             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3431      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3432 C Derivatives in DC(i+1)
3433             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3434      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3435             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3436      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3437             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3438      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3439             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3440      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3441 C Derivatives in DC(j)
3442             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3443      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3444             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3445      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3446             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3447      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3448             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3449      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3450 C Derivatives in DC(j+1) or DC(nres-1)
3451             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3452      &      -3.0d0*vryg(k,3)*ury)
3453             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3454      &      -3.0d0*vrzg(k,3)*ury)
3455             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3456      &      -3.0d0*vryg(k,3)*urz)
3457             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3458      &      -3.0d0*vrzg(k,3)*urz)
3459 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3460 cgrad              do l=1,4
3461 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3462 cgrad              enddo
3463 cgrad            endif
3464           enddo
3465           acipa(1,1)=a22
3466           acipa(1,2)=a23
3467           acipa(2,1)=a32
3468           acipa(2,2)=a33
3469           a22=-a22
3470           a23=-a23
3471           do l=1,2
3472             do k=1,3
3473               agg(k,l)=-agg(k,l)
3474               aggi(k,l)=-aggi(k,l)
3475               aggi1(k,l)=-aggi1(k,l)
3476               aggj(k,l)=-aggj(k,l)
3477               aggj1(k,l)=-aggj1(k,l)
3478             enddo
3479           enddo
3480           if (j.lt.nres-1) then
3481             a22=-a22
3482             a32=-a32
3483             do l=1,3,2
3484               do k=1,3
3485                 agg(k,l)=-agg(k,l)
3486                 aggi(k,l)=-aggi(k,l)
3487                 aggi1(k,l)=-aggi1(k,l)
3488                 aggj(k,l)=-aggj(k,l)
3489                 aggj1(k,l)=-aggj1(k,l)
3490               enddo
3491             enddo
3492           else
3493             a22=-a22
3494             a23=-a23
3495             a32=-a32
3496             a33=-a33
3497             do l=1,4
3498               do k=1,3
3499                 agg(k,l)=-agg(k,l)
3500                 aggi(k,l)=-aggi(k,l)
3501                 aggi1(k,l)=-aggi1(k,l)
3502                 aggj(k,l)=-aggj(k,l)
3503                 aggj1(k,l)=-aggj1(k,l)
3504               enddo
3505             enddo
3506           endif
3507           ENDIF ! WCORR
3508           IF (wel_loc.gt.0.0d0) THEN
3509 C Contribution to the local-electrostatic energy coming from the i-j pair
3510           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3511      &     +a33*muij(4)
3512 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3513
3514           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3515      &            'eelloc',i,j,eel_loc_ij
3516
3517           eel_loc=eel_loc+eel_loc_ij
3518 C Partial derivatives in virtual-bond dihedral angles gamma
3519           if (i.gt.1)
3520      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3521      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3522      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3523           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3524      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3525      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3526 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3527           do l=1,3
3528             ggg(l)=agg(l,1)*muij(1)+
3529      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3530             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3531             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3532 cgrad            ghalf=0.5d0*ggg(l)
3533 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3534 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3535           enddo
3536 cgrad          do k=i+1,j2
3537 cgrad            do l=1,3
3538 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3539 cgrad            enddo
3540 cgrad          enddo
3541 C Remaining derivatives of eello
3542           do l=1,3
3543             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3544      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3545             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3546      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3547             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3548      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3549             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3550      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3551           enddo
3552           ENDIF
3553 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3554 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3555           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3556      &       .and. num_conti.le.maxconts) then
3557 c            write (iout,*) i,j," entered corr"
3558 C
3559 C Calculate the contact function. The ith column of the array JCONT will
3560 C contain the numbers of atoms that make contacts with the atom I (of numbers
3561 C greater than I). The arrays FACONT and GACONT will contain the values of
3562 C the contact function and its derivative.
3563 c           r0ij=1.02D0*rpp(iteli,itelj)
3564 c           r0ij=1.11D0*rpp(iteli,itelj)
3565             r0ij=2.20D0*rpp(iteli,itelj)
3566 c           r0ij=1.55D0*rpp(iteli,itelj)
3567             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3568             if (fcont.gt.0.0D0) then
3569               num_conti=num_conti+1
3570               if (num_conti.gt.maxconts) then
3571                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3572      &                         ' will skip next contacts for this conf.'
3573               else
3574                 jcont_hb(num_conti,i)=j
3575 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3576 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3577                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3578      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3579 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3580 C  terms.
3581                 d_cont(num_conti,i)=rij
3582 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3583 C     --- Electrostatic-interaction matrix ---
3584                 a_chuj(1,1,num_conti,i)=a22
3585                 a_chuj(1,2,num_conti,i)=a23
3586                 a_chuj(2,1,num_conti,i)=a32
3587                 a_chuj(2,2,num_conti,i)=a33
3588 C     --- Gradient of rij
3589                 do kkk=1,3
3590                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3591                 enddo
3592                 kkll=0
3593                 do k=1,2
3594                   do l=1,2
3595                     kkll=kkll+1
3596                     do m=1,3
3597                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3598                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3599                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3600                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3601                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3602                     enddo
3603                   enddo
3604                 enddo
3605                 ENDIF
3606                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3607 C Calculate contact energies
3608                 cosa4=4.0D0*cosa
3609                 wij=cosa-3.0D0*cosb*cosg
3610                 cosbg1=cosb+cosg
3611                 cosbg2=cosb-cosg
3612 c               fac3=dsqrt(-ael6i)/r0ij**3
3613                 fac3=dsqrt(-ael6i)*r3ij
3614 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3615                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3616                 if (ees0tmp.gt.0) then
3617                   ees0pij=dsqrt(ees0tmp)
3618                 else
3619                   ees0pij=0
3620                 endif
3621 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3622                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3623                 if (ees0tmp.gt.0) then
3624                   ees0mij=dsqrt(ees0tmp)
3625                 else
3626                   ees0mij=0
3627                 endif
3628 c               ees0mij=0.0D0
3629                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3630                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3631 C Diagnostics. Comment out or remove after debugging!
3632 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3633 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3634 c               ees0m(num_conti,i)=0.0D0
3635 C End diagnostics.
3636 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3637 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3638 C Angular derivatives of the contact function
3639                 ees0pij1=fac3/ees0pij
3640                 ees0mij1=fac3/ees0mij
3641                 fac3p=-3.0D0*fac3*rrmij
3642                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3643                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3644 c               ees0mij1=0.0D0
3645                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3646                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3647                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3648                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3649                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3650                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3651                 ecosap=ecosa1+ecosa2
3652                 ecosbp=ecosb1+ecosb2
3653                 ecosgp=ecosg1+ecosg2
3654                 ecosam=ecosa1-ecosa2
3655                 ecosbm=ecosb1-ecosb2
3656                 ecosgm=ecosg1-ecosg2
3657 C Diagnostics
3658 c               ecosap=ecosa1
3659 c               ecosbp=ecosb1
3660 c               ecosgp=ecosg1
3661 c               ecosam=0.0D0
3662 c               ecosbm=0.0D0
3663 c               ecosgm=0.0D0
3664 C End diagnostics
3665                 facont_hb(num_conti,i)=fcont
3666                 fprimcont=fprimcont/rij
3667 cd              facont_hb(num_conti,i)=1.0D0
3668 C Following line is for diagnostics.
3669 cd              fprimcont=0.0D0
3670                 do k=1,3
3671                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3672                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3673                 enddo
3674                 do k=1,3
3675                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3676                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3677                 enddo
3678                 gggp(1)=gggp(1)+ees0pijp*xj
3679                 gggp(2)=gggp(2)+ees0pijp*yj
3680                 gggp(3)=gggp(3)+ees0pijp*zj
3681                 gggm(1)=gggm(1)+ees0mijp*xj
3682                 gggm(2)=gggm(2)+ees0mijp*yj
3683                 gggm(3)=gggm(3)+ees0mijp*zj
3684 C Derivatives due to the contact function
3685                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3686                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3687                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3688                 do k=1,3
3689 c
3690 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3691 c          following the change of gradient-summation algorithm.
3692 c
3693 cgrad                  ghalfp=0.5D0*gggp(k)
3694 cgrad                  ghalfm=0.5D0*gggm(k)
3695                   gacontp_hb1(k,num_conti,i)=!ghalfp
3696      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3697      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3698                   gacontp_hb2(k,num_conti,i)=!ghalfp
3699      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3700      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3701                   gacontp_hb3(k,num_conti,i)=gggp(k)
3702                   gacontm_hb1(k,num_conti,i)=!ghalfm
3703      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3704      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3705                   gacontm_hb2(k,num_conti,i)=!ghalfm
3706      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3707      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3708                   gacontm_hb3(k,num_conti,i)=gggm(k)
3709                 enddo
3710 C Diagnostics. Comment out or remove after debugging!
3711 cdiag           do k=1,3
3712 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3713 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3714 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3715 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3716 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3717 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3718 cdiag           enddo
3719               ENDIF ! wcorr
3720               endif  ! num_conti.le.maxconts
3721             endif  ! fcont.gt.0
3722           endif    ! j.gt.i+1
3723           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3724             do k=1,4
3725               do l=1,3
3726                 ghalf=0.5d0*agg(l,k)
3727                 aggi(l,k)=aggi(l,k)+ghalf
3728                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3729                 aggj(l,k)=aggj(l,k)+ghalf
3730               enddo
3731             enddo
3732             if (j.eq.nres-1 .and. i.lt.j-2) then
3733               do k=1,4
3734                 do l=1,3
3735                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3736                 enddo
3737               enddo
3738             endif
3739           endif
3740 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3741       return
3742       end
3743 C-----------------------------------------------------------------------------
3744       subroutine eturn3(i,eello_turn3)
3745 C Third- and fourth-order contributions from turns
3746       implicit real*8 (a-h,o-z)
3747       include 'DIMENSIONS'
3748       include 'COMMON.IOUNITS'
3749       include 'COMMON.GEO'
3750       include 'COMMON.VAR'
3751       include 'COMMON.LOCAL'
3752       include 'COMMON.CHAIN'
3753       include 'COMMON.DERIV'
3754       include 'COMMON.INTERACT'
3755       include 'COMMON.CONTACTS'
3756       include 'COMMON.TORSION'
3757       include 'COMMON.VECTORS'
3758       include 'COMMON.FFIELD'
3759       include 'COMMON.CONTROL'
3760       dimension ggg(3)
3761       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3762      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3763      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3764       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3765      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3766       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3767      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3768      &    num_conti,j1,j2
3769       j=i+2
3770 c      write (iout,*) "eturn3",i,j,j1,j2
3771       a_temp(1,1)=a22
3772       a_temp(1,2)=a23
3773       a_temp(2,1)=a32
3774       a_temp(2,2)=a33
3775 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3776 C
3777 C               Third-order contributions
3778 C
3779 C                 (i+2)o----(i+3)
3780 C                      | |
3781 C                      | |
3782 C                 (i+1)o----i
3783 C
3784 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3785 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3786         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3787         call transpose2(auxmat(1,1),auxmat1(1,1))
3788         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3789         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3790         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3791      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3792 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3793 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3794 cd     &    ' eello_turn3_num',4*eello_turn3_num
3795 C Derivatives in gamma(i)
3796         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3797         call transpose2(auxmat2(1,1),auxmat3(1,1))
3798         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3799         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3800 C Derivatives in gamma(i+1)
3801         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3802         call transpose2(auxmat2(1,1),auxmat3(1,1))
3803         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3804         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3805      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3806 C Cartesian derivatives
3807         do l=1,3
3808 c            ghalf1=0.5d0*agg(l,1)
3809 c            ghalf2=0.5d0*agg(l,2)
3810 c            ghalf3=0.5d0*agg(l,3)
3811 c            ghalf4=0.5d0*agg(l,4)
3812           a_temp(1,1)=aggi(l,1)!+ghalf1
3813           a_temp(1,2)=aggi(l,2)!+ghalf2
3814           a_temp(2,1)=aggi(l,3)!+ghalf3
3815           a_temp(2,2)=aggi(l,4)!+ghalf4
3816           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3817           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3818      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3819           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3820           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3821           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3822           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3823           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3824           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3825      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3826           a_temp(1,1)=aggj(l,1)!+ghalf1
3827           a_temp(1,2)=aggj(l,2)!+ghalf2
3828           a_temp(2,1)=aggj(l,3)!+ghalf3
3829           a_temp(2,2)=aggj(l,4)!+ghalf4
3830           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3831           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3832      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3833           a_temp(1,1)=aggj1(l,1)
3834           a_temp(1,2)=aggj1(l,2)
3835           a_temp(2,1)=aggj1(l,3)
3836           a_temp(2,2)=aggj1(l,4)
3837           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3838           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3839      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3840         enddo
3841       return
3842       end
3843 C-------------------------------------------------------------------------------
3844       subroutine eturn4(i,eello_turn4)
3845 C Third- and fourth-order contributions from turns
3846       implicit real*8 (a-h,o-z)
3847       include 'DIMENSIONS'
3848       include 'COMMON.IOUNITS'
3849       include 'COMMON.GEO'
3850       include 'COMMON.VAR'
3851       include 'COMMON.LOCAL'
3852       include 'COMMON.CHAIN'
3853       include 'COMMON.DERIV'
3854       include 'COMMON.INTERACT'
3855       include 'COMMON.CONTACTS'
3856       include 'COMMON.TORSION'
3857       include 'COMMON.VECTORS'
3858       include 'COMMON.FFIELD'
3859       include 'COMMON.CONTROL'
3860       dimension ggg(3)
3861       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3862      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3863      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3864       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3865      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3866       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3867      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3868      &    num_conti,j1,j2
3869       j=i+3
3870 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3871 C
3872 C               Fourth-order contributions
3873 C
3874 C                 (i+3)o----(i+4)
3875 C                     /  |
3876 C               (i+2)o   |
3877 C                     \  |
3878 C                 (i+1)o----i
3879 C
3880 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3881 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3882 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3883         a_temp(1,1)=a22
3884         a_temp(1,2)=a23
3885         a_temp(2,1)=a32
3886         a_temp(2,2)=a33
3887         iti1=itortyp(itype(i+1))
3888         iti2=itortyp(itype(i+2))
3889         iti3=itortyp(itype(i+3))
3890 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3891         call transpose2(EUg(1,1,i+1),e1t(1,1))
3892         call transpose2(Eug(1,1,i+2),e2t(1,1))
3893         call transpose2(Eug(1,1,i+3),e3t(1,1))
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         eello_turn4=eello_turn4-(s1+s2+s3)
3904         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3905      &      'eturn4',i,j,-(s1+s2+s3)
3906 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3907 cd     &    ' eello_turn4_num',8*eello_turn4_num
3908 C Derivatives in gamma(i)
3909         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3910         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3911         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3912         s1=scalar2(b1(1,iti2),auxvec(1))
3913         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3914         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3915         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3916 C Derivatives in gamma(i+1)
3917         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3918         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3919         s2=scalar2(b1(1,iti1),auxvec(1))
3920         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3921         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3922         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3923         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3924 C Derivatives in gamma(i+2)
3925         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3926         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3927         s1=scalar2(b1(1,iti2),auxvec(1))
3928         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3929         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3930         s2=scalar2(b1(1,iti1),auxvec(1))
3931         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3932         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3933         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3934         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3935 C Cartesian derivatives
3936 C Derivatives of this turn contributions in DC(i+2)
3937         if (j.lt.nres-1) then
3938           do l=1,3
3939             a_temp(1,1)=agg(l,1)
3940             a_temp(1,2)=agg(l,2)
3941             a_temp(2,1)=agg(l,3)
3942             a_temp(2,2)=agg(l,4)
3943             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3944             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3945             s1=scalar2(b1(1,iti2),auxvec(1))
3946             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3947             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3948             s2=scalar2(b1(1,iti1),auxvec(1))
3949             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3950             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3951             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3952             ggg(l)=-(s1+s2+s3)
3953             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3954           enddo
3955         endif
3956 C Remaining derivatives of this turn contribution
3957         do l=1,3
3958           a_temp(1,1)=aggi(l,1)
3959           a_temp(1,2)=aggi(l,2)
3960           a_temp(2,1)=aggi(l,3)
3961           a_temp(2,2)=aggi(l,4)
3962           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3963           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3964           s1=scalar2(b1(1,iti2),auxvec(1))
3965           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3966           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3967           s2=scalar2(b1(1,iti1),auxvec(1))
3968           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3969           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3970           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3971           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3972           a_temp(1,1)=aggi1(l,1)
3973           a_temp(1,2)=aggi1(l,2)
3974           a_temp(2,1)=aggi1(l,3)
3975           a_temp(2,2)=aggi1(l,4)
3976           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3977           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3978           s1=scalar2(b1(1,iti2),auxvec(1))
3979           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3980           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3981           s2=scalar2(b1(1,iti1),auxvec(1))
3982           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3983           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3984           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3985           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3986           a_temp(1,1)=aggj(l,1)
3987           a_temp(1,2)=aggj(l,2)
3988           a_temp(2,1)=aggj(l,3)
3989           a_temp(2,2)=aggj(l,4)
3990           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3991           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3992           s1=scalar2(b1(1,iti2),auxvec(1))
3993           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3994           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3995           s2=scalar2(b1(1,iti1),auxvec(1))
3996           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3997           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3998           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3999           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4000           a_temp(1,1)=aggj1(l,1)
4001           a_temp(1,2)=aggj1(l,2)
4002           a_temp(2,1)=aggj1(l,3)
4003           a_temp(2,2)=aggj1(l,4)
4004           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4005           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4006           s1=scalar2(b1(1,iti2),auxvec(1))
4007           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4008           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4009           s2=scalar2(b1(1,iti1),auxvec(1))
4010           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4011           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4012           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4013 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4014           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4015         enddo
4016       return
4017       end
4018 C-----------------------------------------------------------------------------
4019       subroutine vecpr(u,v,w)
4020       implicit real*8(a-h,o-z)
4021       dimension u(3),v(3),w(3)
4022       w(1)=u(2)*v(3)-u(3)*v(2)
4023       w(2)=-u(1)*v(3)+u(3)*v(1)
4024       w(3)=u(1)*v(2)-u(2)*v(1)
4025       return
4026       end
4027 C-----------------------------------------------------------------------------
4028       subroutine unormderiv(u,ugrad,unorm,ungrad)
4029 C This subroutine computes the derivatives of a normalized vector u, given
4030 C the derivatives computed without normalization conditions, ugrad. Returns
4031 C ungrad.
4032       implicit none
4033       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4034       double precision vec(3)
4035       double precision scalar
4036       integer i,j
4037 c      write (2,*) 'ugrad',ugrad
4038 c      write (2,*) 'u',u
4039       do i=1,3
4040         vec(i)=scalar(ugrad(1,i),u(1))
4041       enddo
4042 c      write (2,*) 'vec',vec
4043       do i=1,3
4044         do j=1,3
4045           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4046         enddo
4047       enddo
4048 c      write (2,*) 'ungrad',ungrad
4049       return
4050       end
4051 C-----------------------------------------------------------------------------
4052       subroutine escp_soft_sphere(evdw2,evdw2_14)
4053 C
4054 C This subroutine calculates the excluded-volume interaction energy between
4055 C peptide-group centers and side chains and its gradient in virtual-bond and
4056 C side-chain vectors.
4057 C
4058       implicit real*8 (a-h,o-z)
4059       include 'DIMENSIONS'
4060       include 'COMMON.GEO'
4061       include 'COMMON.VAR'
4062       include 'COMMON.LOCAL'
4063       include 'COMMON.CHAIN'
4064       include 'COMMON.DERIV'
4065       include 'COMMON.INTERACT'
4066       include 'COMMON.FFIELD'
4067       include 'COMMON.IOUNITS'
4068       include 'COMMON.CONTROL'
4069       dimension ggg(3)
4070       evdw2=0.0D0
4071       evdw2_14=0.0d0
4072       r0_scp=4.5d0
4073 cd    print '(a)','Enter ESCP'
4074 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4075       do i=iatscp_s,iatscp_e
4076         iteli=itel(i)
4077         xi=0.5D0*(c(1,i)+c(1,i+1))
4078         yi=0.5D0*(c(2,i)+c(2,i+1))
4079         zi=0.5D0*(c(3,i)+c(3,i+1))
4080
4081         do iint=1,nscp_gr(i)
4082
4083         do j=iscpstart(i,iint),iscpend(i,iint)
4084           itypj=itype(j)
4085 C Uncomment following three lines for SC-p interactions
4086 c         xj=c(1,nres+j)-xi
4087 c         yj=c(2,nres+j)-yi
4088 c         zj=c(3,nres+j)-zi
4089 C Uncomment following three lines for Ca-p interactions
4090           xj=c(1,j)-xi
4091           yj=c(2,j)-yi
4092           zj=c(3,j)-zi
4093           rij=xj*xj+yj*yj+zj*zj
4094           r0ij=r0_scp
4095           r0ijsq=r0ij*r0ij
4096           if (rij.lt.r0ijsq) then
4097             evdwij=0.25d0*(rij-r0ijsq)**2
4098             fac=rij-r0ijsq
4099           else
4100             evdwij=0.0d0
4101             fac=0.0d0
4102           endif
4103           evdw2=evdw2+evdwij
4104 C
4105 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4106 C
4107           ggg(1)=xj*fac
4108           ggg(2)=yj*fac
4109           ggg(3)=zj*fac
4110 cgrad          if (j.lt.i) then
4111 cd          write (iout,*) 'j<i'
4112 C Uncomment following three lines for SC-p interactions
4113 c           do k=1,3
4114 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4115 c           enddo
4116 cgrad          else
4117 cd          write (iout,*) 'j>i'
4118 cgrad            do k=1,3
4119 cgrad              ggg(k)=-ggg(k)
4120 C Uncomment following line for SC-p interactions
4121 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4122 cgrad            enddo
4123 cgrad          endif
4124 cgrad          do k=1,3
4125 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4126 cgrad          enddo
4127 cgrad          kstart=min0(i+1,j)
4128 cgrad          kend=max0(i-1,j-1)
4129 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4130 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4131 cgrad          do k=kstart,kend
4132 cgrad            do l=1,3
4133 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4134 cgrad            enddo
4135 cgrad          enddo
4136           do k=1,3
4137             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4138             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4139           enddo
4140         enddo
4141
4142         enddo ! iint
4143       enddo ! i
4144       return
4145       end
4146 C-----------------------------------------------------------------------------
4147       subroutine escp(evdw2,evdw2_14)
4148 C
4149 C This subroutine calculates the excluded-volume interaction energy between
4150 C peptide-group centers and side chains and its gradient in virtual-bond and
4151 C side-chain vectors.
4152 C
4153       implicit real*8 (a-h,o-z)
4154       include 'DIMENSIONS'
4155       include 'COMMON.GEO'
4156       include 'COMMON.VAR'
4157       include 'COMMON.LOCAL'
4158       include 'COMMON.CHAIN'
4159       include 'COMMON.DERIV'
4160       include 'COMMON.INTERACT'
4161       include 'COMMON.FFIELD'
4162       include 'COMMON.IOUNITS'
4163       include 'COMMON.CONTROL'
4164       dimension ggg(3)
4165       evdw2=0.0D0
4166       evdw2_14=0.0d0
4167 cd    print '(a)','Enter ESCP'
4168 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4169       do i=iatscp_s,iatscp_e
4170         iteli=itel(i)
4171         xi=0.5D0*(c(1,i)+c(1,i+1))
4172         yi=0.5D0*(c(2,i)+c(2,i+1))
4173         zi=0.5D0*(c(3,i)+c(3,i+1))
4174
4175         do iint=1,nscp_gr(i)
4176
4177         do j=iscpstart(i,iint),iscpend(i,iint)
4178           itypj=itype(j)
4179 C Uncomment following three lines for SC-p interactions
4180 c         xj=c(1,nres+j)-xi
4181 c         yj=c(2,nres+j)-yi
4182 c         zj=c(3,nres+j)-zi
4183 C Uncomment following three lines for Ca-p interactions
4184           xj=c(1,j)-xi
4185           yj=c(2,j)-yi
4186           zj=c(3,j)-zi
4187           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4188           fac=rrij**expon2
4189           e1=fac*fac*aad(itypj,iteli)
4190           e2=fac*bad(itypj,iteli)
4191           if (iabs(j-i) .le. 2) then
4192             e1=scal14*e1
4193             e2=scal14*e2
4194             evdw2_14=evdw2_14+e1+e2
4195           endif
4196           evdwij=e1+e2
4197           evdw2=evdw2+evdwij
4198           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4199      &        'evdw2',i,j,evdwij
4200 C
4201 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4202 C
4203           fac=-(evdwij+e1)*rrij
4204           ggg(1)=xj*fac
4205           ggg(2)=yj*fac
4206           ggg(3)=zj*fac
4207 cgrad          if (j.lt.i) then
4208 cd          write (iout,*) 'j<i'
4209 C Uncomment following three lines for SC-p interactions
4210 c           do k=1,3
4211 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4212 c           enddo
4213 cgrad          else
4214 cd          write (iout,*) 'j>i'
4215 cgrad            do k=1,3
4216 cgrad              ggg(k)=-ggg(k)
4217 C Uncomment following line for SC-p interactions
4218 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4219 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4220 cgrad            enddo
4221 cgrad          endif
4222 cgrad          do k=1,3
4223 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4224 cgrad          enddo
4225 cgrad          kstart=min0(i+1,j)
4226 cgrad          kend=max0(i-1,j-1)
4227 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4228 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4229 cgrad          do k=kstart,kend
4230 cgrad            do l=1,3
4231 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4232 cgrad            enddo
4233 cgrad          enddo
4234           do k=1,3
4235             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4236             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4237           enddo
4238         enddo
4239
4240         enddo ! iint
4241       enddo ! i
4242       do i=1,nct
4243         do j=1,3
4244           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4245           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4246           gradx_scp(j,i)=expon*gradx_scp(j,i)
4247         enddo
4248       enddo
4249 C******************************************************************************
4250 C
4251 C                              N O T E !!!
4252 C
4253 C To save time the factor EXPON has been extracted from ALL components
4254 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4255 C use!
4256 C
4257 C******************************************************************************
4258       return
4259       end
4260 C--------------------------------------------------------------------------
4261       subroutine edis(ehpb)
4262 C
4263 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4264 C
4265       implicit real*8 (a-h,o-z)
4266       include 'DIMENSIONS'
4267       include 'COMMON.SBRIDGE'
4268       include 'COMMON.CHAIN'
4269       include 'COMMON.DERIV'
4270       include 'COMMON.VAR'
4271       include 'COMMON.INTERACT'
4272       include 'COMMON.IOUNITS'
4273       dimension ggg(3)
4274       ehpb=0.0D0
4275 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4276 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4277       if (link_end.eq.0) return
4278       do i=link_start,link_end
4279 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4280 C CA-CA distance used in regularization of structure.
4281         ii=ihpb(i)
4282         jj=jhpb(i)
4283 C iii and jjj point to the residues for which the distance is assigned.
4284         if (ii.gt.nres) then
4285           iii=ii-nres
4286           jjj=jj-nres
4287         else
4288           iii=ii
4289           jjj=jj
4290         endif
4291 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4292 c     &    dhpb(i),dhpb1(i),forcon(i)
4293 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4294 C    distance and angle dependent SS bond potential.
4295 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4296 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4297         if (.not.dyn_ss .and. i.le.nss) then
4298 C 15/02/13 CC dynamic SSbond - additional check
4299          if (ii.gt.nres
4300      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4301           call ssbond_ene(iii,jjj,eij)
4302           ehpb=ehpb+2*eij
4303          endif
4304 cd          write (iout,*) "eij",eij
4305         else if (ii.gt.nres .and. jj.gt.nres) then
4306 c Restraints from contact prediction
4307           dd=dist(ii,jj)
4308           if (dhpb1(i).gt.0.0d0) then
4309             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4310             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4311 c            write (iout,*) "beta nmr",
4312 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4313           else
4314             dd=dist(ii,jj)
4315             rdis=dd-dhpb(i)
4316 C Get the force constant corresponding to this distance.
4317             waga=forcon(i)
4318 C Calculate the contribution to energy.
4319             ehpb=ehpb+waga*rdis*rdis
4320 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4321 C
4322 C Evaluate gradient.
4323 C
4324             fac=waga*rdis/dd
4325           endif
4326           do j=1,3
4327             ggg(j)=fac*(c(j,jj)-c(j,ii))
4328           enddo
4329           do j=1,3
4330             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4331             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4332           enddo
4333           do k=1,3
4334             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4335             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4336           enddo
4337         else
4338 C Calculate the distance between the two points and its difference from the
4339 C target distance.
4340           dd=dist(ii,jj)
4341           if (dhpb1(i).gt.0.0d0) then
4342             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4343             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4344 c            write (iout,*) "alph nmr",
4345 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4346           else
4347             rdis=dd-dhpb(i)
4348 C Get the force constant corresponding to this distance.
4349             waga=forcon(i)
4350 C Calculate the contribution to energy.
4351             ehpb=ehpb+waga*rdis*rdis
4352 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4353 C
4354 C Evaluate gradient.
4355 C
4356             fac=waga*rdis/dd
4357           endif
4358 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4359 cd   &   ' waga=',waga,' fac=',fac
4360             do j=1,3
4361               ggg(j)=fac*(c(j,jj)-c(j,ii))
4362             enddo
4363 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4364 C If this is a SC-SC distance, we need to calculate the contributions to the
4365 C Cartesian gradient in the SC vectors (ghpbx).
4366           if (iii.lt.ii) then
4367           do j=1,3
4368             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4369             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4370           enddo
4371           endif
4372 cgrad        do j=iii,jjj-1
4373 cgrad          do k=1,3
4374 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4375 cgrad          enddo
4376 cgrad        enddo
4377           do k=1,3
4378             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4379             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4380           enddo
4381         endif
4382       enddo
4383       ehpb=0.5D0*ehpb
4384       return
4385       end
4386 C--------------------------------------------------------------------------
4387       subroutine ssbond_ene(i,j,eij)
4388 C
4389 C Calculate the distance and angle dependent SS-bond potential energy
4390 C using a free-energy function derived based on RHF/6-31G** ab initio
4391 C calculations of diethyl disulfide.
4392 C
4393 C A. Liwo and U. Kozlowska, 11/24/03
4394 C
4395       implicit real*8 (a-h,o-z)
4396       include 'DIMENSIONS'
4397       include 'COMMON.SBRIDGE'
4398       include 'COMMON.CHAIN'
4399       include 'COMMON.DERIV'
4400       include 'COMMON.LOCAL'
4401       include 'COMMON.INTERACT'
4402       include 'COMMON.VAR'
4403       include 'COMMON.IOUNITS'
4404       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4405       itypi=itype(i)
4406       xi=c(1,nres+i)
4407       yi=c(2,nres+i)
4408       zi=c(3,nres+i)
4409       dxi=dc_norm(1,nres+i)
4410       dyi=dc_norm(2,nres+i)
4411       dzi=dc_norm(3,nres+i)
4412 c      dsci_inv=dsc_inv(itypi)
4413       dsci_inv=vbld_inv(nres+i)
4414       itypj=itype(j)
4415 c      dscj_inv=dsc_inv(itypj)
4416       dscj_inv=vbld_inv(nres+j)
4417       xj=c(1,nres+j)-xi
4418       yj=c(2,nres+j)-yi
4419       zj=c(3,nres+j)-zi
4420       dxj=dc_norm(1,nres+j)
4421       dyj=dc_norm(2,nres+j)
4422       dzj=dc_norm(3,nres+j)
4423       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4424       rij=dsqrt(rrij)
4425       erij(1)=xj*rij
4426       erij(2)=yj*rij
4427       erij(3)=zj*rij
4428       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4429       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4430       om12=dxi*dxj+dyi*dyj+dzi*dzj
4431       do k=1,3
4432         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4433         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4434       enddo
4435       rij=1.0d0/rij
4436       deltad=rij-d0cm
4437       deltat1=1.0d0-om1
4438       deltat2=1.0d0+om2
4439       deltat12=om2-om1+2.0d0
4440       cosphi=om12-om1*om2
4441       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4442      &  +akct*deltad*deltat12+ebr
4443      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4444 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4445 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4446 c     &  " deltat12",deltat12," eij",eij
4447       ed=2*akcm*deltad+akct*deltat12
4448       pom1=akct*deltad
4449       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4450       eom1=-2*akth*deltat1-pom1-om2*pom2
4451       eom2= 2*akth*deltat2+pom1-om1*pom2
4452       eom12=pom2
4453       do k=1,3
4454         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4455         ghpbx(k,i)=ghpbx(k,i)-ggk
4456      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4457      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4458         ghpbx(k,j)=ghpbx(k,j)+ggk
4459      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4460      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4461         ghpbc(k,i)=ghpbc(k,i)-ggk
4462         ghpbc(k,j)=ghpbc(k,j)+ggk
4463       enddo
4464 C
4465 C Calculate the components of the gradient in DC and X
4466 C
4467 cgrad      do k=i,j-1
4468 cgrad        do l=1,3
4469 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4470 cgrad        enddo
4471 cgrad      enddo
4472       return
4473       end
4474 C--------------------------------------------------------------------------
4475       subroutine ebond(estr)
4476 c
4477 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4478 c
4479       implicit real*8 (a-h,o-z)
4480       include 'DIMENSIONS'
4481       include 'COMMON.LOCAL'
4482       include 'COMMON.GEO'
4483       include 'COMMON.INTERACT'
4484       include 'COMMON.DERIV'
4485       include 'COMMON.VAR'
4486       include 'COMMON.CHAIN'
4487       include 'COMMON.IOUNITS'
4488       include 'COMMON.NAMES'
4489       include 'COMMON.FFIELD'
4490       include 'COMMON.CONTROL'
4491       include 'COMMON.SETUP'
4492       double precision u(3),ud(3)
4493       estr=0.0d0
4494       do i=ibondp_start,ibondp_end
4495         diff = vbld(i)-vbldp0
4496 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4497         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
4498      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4499         estr=estr+diff*diff
4500         do j=1,3
4501           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4502         enddo
4503 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4504       enddo
4505       estr=0.5d0*AKP*estr
4506 c
4507 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4508 c
4509       do i=ibond_start,ibond_end
4510         iti=itype(i)
4511         if (iti.ne.10) then
4512           nbi=nbondterm(iti)
4513           if (nbi.eq.1) then
4514             diff=vbld(i+nres)-vbldsc0(1,iti)
4515 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4516 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4517             if (energy_dec)  then
4518               write (iout,*)
4519      &         "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4520      &         AKSC(1,iti),AKSC(1,iti)*diff*diff
4521               call flush(iout)
4522             endif
4523             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4524             do j=1,3
4525               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4526             enddo
4527           else
4528             do j=1,nbi
4529               diff=vbld(i+nres)-vbldsc0(j,iti)
4530               ud(j)=aksc(j,iti)*diff
4531               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4532             enddo
4533             uprod=u(1)
4534             do j=2,nbi
4535               uprod=uprod*u(j)
4536             enddo
4537             usum=0.0d0
4538             usumsqder=0.0d0
4539             do j=1,nbi
4540               uprod1=1.0d0
4541               uprod2=1.0d0
4542               do k=1,nbi
4543                 if (k.ne.j) then
4544                   uprod1=uprod1*u(k)
4545                   uprod2=uprod2*u(k)*u(k)
4546                 endif
4547               enddo
4548               usum=usum+uprod1
4549               usumsqder=usumsqder+ud(j)*uprod2
4550             enddo
4551             estr=estr+uprod/usum
4552             do j=1,3
4553              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4554             enddo
4555           endif
4556         endif
4557       enddo
4558       return
4559       end
4560 #ifdef CRYST_THETA
4561 C--------------------------------------------------------------------------
4562       subroutine ebend(etheta)
4563 C
4564 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4565 C angles gamma and its derivatives in consecutive thetas and gammas.
4566 C
4567       implicit real*8 (a-h,o-z)
4568       include 'DIMENSIONS'
4569       include 'COMMON.LOCAL'
4570       include 'COMMON.GEO'
4571       include 'COMMON.INTERACT'
4572       include 'COMMON.DERIV'
4573       include 'COMMON.VAR'
4574       include 'COMMON.CHAIN'
4575       include 'COMMON.IOUNITS'
4576       include 'COMMON.NAMES'
4577       include 'COMMON.FFIELD'
4578       include 'COMMON.CONTROL'
4579       common /calcthet/ term1,term2,termm,diffak,ratak,
4580      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4581      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4582       double precision y(2),z(2)
4583       delta=0.02d0*pi
4584 c      time11=dexp(-2*time)
4585 c      time12=1.0d0
4586       etheta=0.0D0
4587 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4588       do i=ithet_start,ithet_end
4589 C Zero the energy function and its derivative at 0 or pi.
4590         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4591         it=itype(i-1)
4592         if (i.gt.3) then
4593 #ifdef OSF
4594           phii=phi(i)
4595           if (phii.ne.phii) phii=150.0
4596 #else
4597           phii=phi(i)
4598 #endif
4599           y(1)=dcos(phii)
4600           y(2)=dsin(phii)
4601         else
4602           y(1)=0.0D0
4603           y(2)=0.0D0
4604         endif
4605         if (i.lt.nres) then
4606 #ifdef OSF
4607           phii1=phi(i+1)
4608           if (phii1.ne.phii1) phii1=150.0
4609           phii1=pinorm(phii1)
4610           z(1)=cos(phii1)
4611 #else
4612           phii1=phi(i+1)
4613           z(1)=dcos(phii1)
4614 #endif
4615           z(2)=dsin(phii1)
4616         else
4617           z(1)=0.0D0
4618           z(2)=0.0D0
4619         endif
4620 C Calculate the "mean" value of theta from the part of the distribution
4621 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4622 C In following comments this theta will be referred to as t_c.
4623         thet_pred_mean=0.0d0
4624         do k=1,2
4625           athetk=athet(k,it)
4626           bthetk=bthet(k,it)
4627           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4628         enddo
4629         dthett=thet_pred_mean*ssd
4630         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4631 C Derivatives of the "mean" values in gamma1 and gamma2.
4632         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4633         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4634         if (theta(i).gt.pi-delta) then
4635           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4636      &         E_tc0)
4637           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4638           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4639           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4640      &        E_theta)
4641           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4642      &        E_tc)
4643         else if (theta(i).lt.delta) then
4644           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4645           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4646           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4647      &        E_theta)
4648           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4649           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4650      &        E_tc)
4651         else
4652           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4653      &        E_theta,E_tc)
4654         endif
4655         etheta=etheta+ethetai
4656         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4657      &      'ebend',i,ethetai
4658         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4659         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4660         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4661       enddo
4662 C Ufff.... We've done all this!!!
4663       return
4664       end
4665 C---------------------------------------------------------------------------
4666       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4667      &     E_tc)
4668       implicit real*8 (a-h,o-z)
4669       include 'DIMENSIONS'
4670       include 'COMMON.LOCAL'
4671       include 'COMMON.IOUNITS'
4672       common /calcthet/ term1,term2,termm,diffak,ratak,
4673      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4674      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4675 C Calculate the contributions to both Gaussian lobes.
4676 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4677 C The "polynomial part" of the "standard deviation" of this part of
4678 C the distribution.
4679         sig=polthet(3,it)
4680         do j=2,0,-1
4681           sig=sig*thet_pred_mean+polthet(j,it)
4682         enddo
4683 C Derivative of the "interior part" of the "standard deviation of the"
4684 C gamma-dependent Gaussian lobe in t_c.
4685         sigtc=3*polthet(3,it)
4686         do j=2,1,-1
4687           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4688         enddo
4689         sigtc=sig*sigtc
4690 C Set the parameters of both Gaussian lobes of the distribution.
4691 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4692         fac=sig*sig+sigc0(it)
4693         sigcsq=fac+fac
4694         sigc=1.0D0/sigcsq
4695 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4696         sigsqtc=-4.0D0*sigcsq*sigtc
4697 c       print *,i,sig,sigtc,sigsqtc
4698 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4699         sigtc=-sigtc/(fac*fac)
4700 C Following variable is sigma(t_c)**(-2)
4701         sigcsq=sigcsq*sigcsq
4702         sig0i=sig0(it)
4703         sig0inv=1.0D0/sig0i**2
4704         delthec=thetai-thet_pred_mean
4705         delthe0=thetai-theta0i
4706         term1=-0.5D0*sigcsq*delthec*delthec
4707         term2=-0.5D0*sig0inv*delthe0*delthe0
4708 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4709 C NaNs in taking the logarithm. We extract the largest exponent which is added
4710 C to the energy (this being the log of the distribution) at the end of energy
4711 C term evaluation for this virtual-bond angle.
4712         if (term1.gt.term2) then
4713           termm=term1
4714           term2=dexp(term2-termm)
4715           term1=1.0d0
4716         else
4717           termm=term2
4718           term1=dexp(term1-termm)
4719           term2=1.0d0
4720         endif
4721 C The ratio between the gamma-independent and gamma-dependent lobes of
4722 C the distribution is a Gaussian function of thet_pred_mean too.
4723         diffak=gthet(2,it)-thet_pred_mean
4724         ratak=diffak/gthet(3,it)**2
4725         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4726 C Let's differentiate it in thet_pred_mean NOW.
4727         aktc=ak*ratak
4728 C Now put together the distribution terms to make complete distribution.
4729         termexp=term1+ak*term2
4730         termpre=sigc+ak*sig0i
4731 C Contribution of the bending energy from this theta is just the -log of
4732 C the sum of the contributions from the two lobes and the pre-exponential
4733 C factor. Simple enough, isn't it?
4734         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4735 C NOW the derivatives!!!
4736 C 6/6/97 Take into account the deformation.
4737         E_theta=(delthec*sigcsq*term1
4738      &       +ak*delthe0*sig0inv*term2)/termexp
4739         E_tc=((sigtc+aktc*sig0i)/termpre
4740      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4741      &       aktc*term2)/termexp)
4742       return
4743       end
4744 c-----------------------------------------------------------------------------
4745       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4746       implicit real*8 (a-h,o-z)
4747       include 'DIMENSIONS'
4748       include 'COMMON.LOCAL'
4749       include 'COMMON.IOUNITS'
4750       common /calcthet/ term1,term2,termm,diffak,ratak,
4751      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4752      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4753       delthec=thetai-thet_pred_mean
4754       delthe0=thetai-theta0i
4755 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4756       t3 = thetai-thet_pred_mean
4757       t6 = t3**2
4758       t9 = term1
4759       t12 = t3*sigcsq
4760       t14 = t12+t6*sigsqtc
4761       t16 = 1.0d0
4762       t21 = thetai-theta0i
4763       t23 = t21**2
4764       t26 = term2
4765       t27 = t21*t26
4766       t32 = termexp
4767       t40 = t32**2
4768       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4769      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4770      & *(-t12*t9-ak*sig0inv*t27)
4771       return
4772       end
4773 #else
4774 C--------------------------------------------------------------------------
4775       subroutine ebend(etheta)
4776 C
4777 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4778 C angles gamma and its derivatives in consecutive thetas and gammas.
4779 C ab initio-derived potentials from
4780 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4781 C
4782       implicit real*8 (a-h,o-z)
4783       include 'DIMENSIONS'
4784       include 'COMMON.LOCAL'
4785       include 'COMMON.GEO'
4786       include 'COMMON.INTERACT'
4787       include 'COMMON.DERIV'
4788       include 'COMMON.VAR'
4789       include 'COMMON.CHAIN'
4790       include 'COMMON.IOUNITS'
4791       include 'COMMON.NAMES'
4792       include 'COMMON.FFIELD'
4793       include 'COMMON.CONTROL'
4794       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4795      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4796      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4797      & sinph1ph2(maxdouble,maxdouble)
4798       logical lprn /.false./, lprn1 /.false./
4799       etheta=0.0D0
4800       do i=ithet_start,ithet_end
4801         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4802      &(itype(i).eq.ntyp1)) cycle
4803         dethetai=0.0d0
4804         dephii=0.0d0
4805         dephii1=0.0d0
4806         theti2=0.5d0*theta(i)
4807         ityp2=ithetyp(itype(i-1))
4808         do k=1,nntheterm
4809           coskt(k)=dcos(k*theti2)
4810           sinkt(k)=dsin(k*theti2)
4811         enddo
4812 C        if (i.gt.3) then
4813         if (i.gt.3 .and. itype(imax0(i-3,1)).ne.ntyp1) then
4814 #ifdef OSF
4815           phii=phi(i)
4816           if (phii.ne.phii) phii=150.0
4817 #else
4818           phii=phi(i)
4819 #endif
4820           ityp1=ithetyp(itype(i-2))
4821           do k=1,nsingle
4822             cosph1(k)=dcos(k*phii)
4823             sinph1(k)=dsin(k*phii)
4824           enddo
4825         else
4826           phii=0.0d0
4827           ityp1=ithetyp(itype(i-2))
4828           do k=1,nsingle
4829             cosph1(k)=0.0d0
4830             sinph1(k)=0.0d0
4831           enddo
4832         endif
4833         if ((i.lt.nres).and. itype(i+1).ne.ntyp1) then
4834 #ifdef OSF
4835           phii1=phi(i+1)
4836           if (phii1.ne.phii1) phii1=150.0
4837           phii1=pinorm(phii1)
4838 #else
4839           phii1=phi(i+1)
4840 #endif
4841           ityp3=ithetyp(itype(i))
4842           do k=1,nsingle
4843             cosph2(k)=dcos(k*phii1)
4844             sinph2(k)=dsin(k*phii1)
4845           enddo
4846         else
4847           phii1=0.0d0
4848           ityp3=ithetyp(itype(i))
4849           do k=1,nsingle
4850             cosph2(k)=0.0d0
4851             sinph2(k)=0.0d0
4852           enddo
4853         endif
4854         ethetai=aa0thet(ityp1,ityp2,ityp3)
4855         do k=1,ndouble
4856           do l=1,k-1
4857             ccl=cosph1(l)*cosph2(k-l)
4858             ssl=sinph1(l)*sinph2(k-l)
4859             scl=sinph1(l)*cosph2(k-l)
4860             csl=cosph1(l)*sinph2(k-l)
4861             cosph1ph2(l,k)=ccl-ssl
4862             cosph1ph2(k,l)=ccl+ssl
4863             sinph1ph2(l,k)=scl+csl
4864             sinph1ph2(k,l)=scl-csl
4865           enddo
4866         enddo
4867         if (lprn) then
4868         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4869      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4870         write (iout,*) "coskt and sinkt"
4871         do k=1,nntheterm
4872           write (iout,*) k,coskt(k),sinkt(k)
4873         enddo
4874         endif
4875         do k=1,ntheterm
4876           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4877           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4878      &      *coskt(k)
4879           if (lprn)
4880      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4881      &     " ethetai",ethetai
4882         enddo
4883         if (lprn) then
4884         write (iout,*) "cosph and sinph"
4885         do k=1,nsingle
4886           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4887         enddo
4888         write (iout,*) "cosph1ph2 and sinph2ph2"
4889         do k=2,ndouble
4890           do l=1,k-1
4891             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4892      &         sinph1ph2(l,k),sinph1ph2(k,l)
4893           enddo
4894         enddo
4895         write(iout,*) "ethetai",ethetai
4896         endif
4897         do m=1,ntheterm2
4898           do k=1,nsingle
4899             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4900      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4901      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4902      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4903             ethetai=ethetai+sinkt(m)*aux
4904             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4905             dephii=dephii+k*sinkt(m)*(
4906      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4907      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4908             dephii1=dephii1+k*sinkt(m)*(
4909      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4910      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4911             if (lprn)
4912      &      write (iout,*) "m",m," k",k," bbthet",
4913      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4914      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4915      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4916      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4917           enddo
4918         enddo
4919         if (lprn)
4920      &  write(iout,*) "ethetai",ethetai
4921         do m=1,ntheterm3
4922           do k=2,ndouble
4923             do l=1,k-1
4924               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4925      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4926      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4927      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4928               ethetai=ethetai+sinkt(m)*aux
4929               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4930               dephii=dephii+l*sinkt(m)*(
4931      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4932      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4933      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4934      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4935               dephii1=dephii1+(k-l)*sinkt(m)*(
4936      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4937      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4938      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4939      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4940               if (lprn) then
4941               write (iout,*) "m",m," k",k," l",l," ffthet",
4942      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4943      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4944      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4945      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4946               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4947      &            cosph1ph2(k,l)*sinkt(m),
4948      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4949               endif
4950             enddo
4951           enddo
4952         enddo
4953 10      continue
4954         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4955      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
4956      &   phii1*rad2deg,ethetai
4957         etheta=etheta+ethetai
4958         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4959      &      'ebend',i,ethetai
4960         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4961         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4962         gloc(nphi+i-2,icg)=wang*dethetai
4963       enddo
4964       return
4965       end
4966 #endif
4967 #ifdef CRYST_SC
4968 c-----------------------------------------------------------------------------
4969       subroutine esc(escloc)
4970 C Calculate the local energy of a side chain and its derivatives in the
4971 C corresponding virtual-bond valence angles THETA and the spherical angles
4972 C ALPHA and OMEGA.
4973       implicit real*8 (a-h,o-z)
4974       include 'DIMENSIONS'
4975       include 'COMMON.GEO'
4976       include 'COMMON.LOCAL'
4977       include 'COMMON.VAR'
4978       include 'COMMON.INTERACT'
4979       include 'COMMON.DERIV'
4980       include 'COMMON.CHAIN'
4981       include 'COMMON.IOUNITS'
4982       include 'COMMON.NAMES'
4983       include 'COMMON.FFIELD'
4984       include 'COMMON.CONTROL'
4985       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4986      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4987       common /sccalc/ time11,time12,time112,theti,it,nlobit
4988       delta=0.02d0*pi
4989       escloc=0.0D0
4990 c     write (iout,'(a)') 'ESC'
4991       do i=loc_start,loc_end
4992         it=itype(i)
4993         if (it.eq.10) goto 1
4994         nlobit=nlob(it)
4995 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4996 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4997         theti=theta(i+1)-pipol
4998         x(1)=dtan(theti)
4999         x(2)=alph(i)
5000         x(3)=omeg(i)
5001
5002         if (x(2).gt.pi-delta) then
5003           xtemp(1)=x(1)
5004           xtemp(2)=pi-delta
5005           xtemp(3)=x(3)
5006           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5007           xtemp(2)=pi
5008           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5009           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5010      &        escloci,dersc(2))
5011           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5012      &        ddersc0(1),dersc(1))
5013           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5014      &        ddersc0(3),dersc(3))
5015           xtemp(2)=pi-delta
5016           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5017           xtemp(2)=pi
5018           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5019           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5020      &            dersc0(2),esclocbi,dersc02)
5021           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5022      &            dersc12,dersc01)
5023           call splinthet(x(2),0.5d0*delta,ss,ssd)
5024           dersc0(1)=dersc01
5025           dersc0(2)=dersc02
5026           dersc0(3)=0.0d0
5027           do k=1,3
5028             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5029           enddo
5030           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5031 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5032 c    &             esclocbi,ss,ssd
5033           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5034 c         escloci=esclocbi
5035 c         write (iout,*) escloci
5036         else if (x(2).lt.delta) then
5037           xtemp(1)=x(1)
5038           xtemp(2)=delta
5039           xtemp(3)=x(3)
5040           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5041           xtemp(2)=0.0d0
5042           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5043           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5044      &        escloci,dersc(2))
5045           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5046      &        ddersc0(1),dersc(1))
5047           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5048      &        ddersc0(3),dersc(3))
5049           xtemp(2)=delta
5050           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5051           xtemp(2)=0.0d0
5052           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5053           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5054      &            dersc0(2),esclocbi,dersc02)
5055           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5056      &            dersc12,dersc01)
5057           dersc0(1)=dersc01
5058           dersc0(2)=dersc02
5059           dersc0(3)=0.0d0
5060           call splinthet(x(2),0.5d0*delta,ss,ssd)
5061           do k=1,3
5062             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5063           enddo
5064           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5065 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5066 c    &             esclocbi,ss,ssd
5067           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5068 c         write (iout,*) escloci
5069         else
5070           call enesc(x,escloci,dersc,ddummy,.false.)
5071         endif
5072
5073         escloc=escloc+escloci
5074         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5075      &     'escloc',i,escloci
5076 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5077
5078         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5079      &   wscloc*dersc(1)
5080         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5081         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5082     1   continue
5083       enddo
5084       return
5085       end
5086 C---------------------------------------------------------------------------
5087       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5088       implicit real*8 (a-h,o-z)
5089       include 'DIMENSIONS'
5090       include 'COMMON.GEO'
5091       include 'COMMON.LOCAL'
5092       include 'COMMON.IOUNITS'
5093       common /sccalc/ time11,time12,time112,theti,it,nlobit
5094       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5095       double precision contr(maxlob,-1:1)
5096       logical mixed
5097 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5098         escloc_i=0.0D0
5099         do j=1,3
5100           dersc(j)=0.0D0
5101           if (mixed) ddersc(j)=0.0d0
5102         enddo
5103         x3=x(3)
5104
5105 C Because of periodicity of the dependence of the SC energy in omega we have
5106 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5107 C To avoid underflows, first compute & store the exponents.
5108
5109         do iii=-1,1
5110
5111           x(3)=x3+iii*dwapi
5112
5113           do j=1,nlobit
5114             do k=1,3
5115               z(k)=x(k)-censc(k,j,it)
5116             enddo
5117             do k=1,3
5118               Axk=0.0D0
5119               do l=1,3
5120                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5121               enddo
5122               Ax(k,j,iii)=Axk
5123             enddo
5124             expfac=0.0D0
5125             do k=1,3
5126               expfac=expfac+Ax(k,j,iii)*z(k)
5127             enddo
5128             contr(j,iii)=expfac
5129           enddo ! j
5130
5131         enddo ! iii
5132
5133         x(3)=x3
5134 C As in the case of ebend, we want to avoid underflows in exponentiation and
5135 C subsequent NaNs and INFs in energy calculation.
5136 C Find the largest exponent
5137         emin=contr(1,-1)
5138         do iii=-1,1
5139           do j=1,nlobit
5140             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5141           enddo
5142         enddo
5143         emin=0.5D0*emin
5144 cd      print *,'it=',it,' emin=',emin
5145
5146 C Compute the contribution to SC energy and derivatives
5147         do iii=-1,1
5148
5149           do j=1,nlobit
5150 #ifdef OSF
5151             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5152             if(adexp.ne.adexp) adexp=1.0
5153             expfac=dexp(adexp)
5154 #else
5155             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5156 #endif
5157 cd          print *,'j=',j,' expfac=',expfac
5158             escloc_i=escloc_i+expfac
5159             do k=1,3
5160               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5161             enddo
5162             if (mixed) then
5163               do k=1,3,2
5164                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5165      &            +gaussc(k,2,j,it))*expfac
5166               enddo
5167             endif
5168           enddo
5169
5170         enddo ! iii
5171
5172         dersc(1)=dersc(1)/cos(theti)**2
5173         ddersc(1)=ddersc(1)/cos(theti)**2
5174         ddersc(3)=ddersc(3)
5175
5176         escloci=-(dlog(escloc_i)-emin)
5177         do j=1,3
5178           dersc(j)=dersc(j)/escloc_i
5179         enddo
5180         if (mixed) then
5181           do j=1,3,2
5182             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5183           enddo
5184         endif
5185       return
5186       end
5187 C------------------------------------------------------------------------------
5188       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5189       implicit real*8 (a-h,o-z)
5190       include 'DIMENSIONS'
5191       include 'COMMON.GEO'
5192       include 'COMMON.LOCAL'
5193       include 'COMMON.IOUNITS'
5194       common /sccalc/ time11,time12,time112,theti,it,nlobit
5195       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5196       double precision contr(maxlob)
5197       logical mixed
5198
5199       escloc_i=0.0D0
5200
5201       do j=1,3
5202         dersc(j)=0.0D0
5203       enddo
5204
5205       do j=1,nlobit
5206         do k=1,2
5207           z(k)=x(k)-censc(k,j,it)
5208         enddo
5209         z(3)=dwapi
5210         do k=1,3
5211           Axk=0.0D0
5212           do l=1,3
5213             Axk=Axk+gaussc(l,k,j,it)*z(l)
5214           enddo
5215           Ax(k,j)=Axk
5216         enddo
5217         expfac=0.0D0
5218         do k=1,3
5219           expfac=expfac+Ax(k,j)*z(k)
5220         enddo
5221         contr(j)=expfac
5222       enddo ! j
5223
5224 C As in the case of ebend, we want to avoid underflows in exponentiation and
5225 C subsequent NaNs and INFs in energy calculation.
5226 C Find the largest exponent
5227       emin=contr(1)
5228       do j=1,nlobit
5229         if (emin.gt.contr(j)) emin=contr(j)
5230       enddo
5231       emin=0.5D0*emin
5232
5233 C Compute the contribution to SC energy and derivatives
5234
5235       dersc12=0.0d0
5236       do j=1,nlobit
5237         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5238         escloc_i=escloc_i+expfac
5239         do k=1,2
5240           dersc(k)=dersc(k)+Ax(k,j)*expfac
5241         enddo
5242         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5243      &            +gaussc(1,2,j,it))*expfac
5244         dersc(3)=0.0d0
5245       enddo
5246
5247       dersc(1)=dersc(1)/cos(theti)**2
5248       dersc12=dersc12/cos(theti)**2
5249       escloci=-(dlog(escloc_i)-emin)
5250       do j=1,2
5251         dersc(j)=dersc(j)/escloc_i
5252       enddo
5253       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5254       return
5255       end
5256 #else
5257 c----------------------------------------------------------------------------------
5258       subroutine esc(escloc)
5259 C Calculate the local energy of a side chain and its derivatives in the
5260 C corresponding virtual-bond valence angles THETA and the spherical angles
5261 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5262 C added by Urszula Kozlowska. 07/11/2007
5263 C
5264       implicit real*8 (a-h,o-z)
5265       include 'DIMENSIONS'
5266       include 'COMMON.GEO'
5267       include 'COMMON.LOCAL'
5268       include 'COMMON.VAR'
5269       include 'COMMON.SCROT'
5270       include 'COMMON.INTERACT'
5271       include 'COMMON.DERIV'
5272       include 'COMMON.CHAIN'
5273       include 'COMMON.IOUNITS'
5274       include 'COMMON.NAMES'
5275       include 'COMMON.FFIELD'
5276       include 'COMMON.CONTROL'
5277       include 'COMMON.VECTORS'
5278       double precision x_prime(3),y_prime(3),z_prime(3)
5279      &    , sumene,dsc_i,dp2_i,x(65),
5280      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5281      &    de_dxx,de_dyy,de_dzz,de_dt
5282       double precision s1_t,s1_6_t,s2_t,s2_6_t
5283       double precision
5284      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5285      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5286      & dt_dCi(3),dt_dCi1(3)
5287       common /sccalc/ time11,time12,time112,theti,it,nlobit
5288       delta=0.02d0*pi
5289       escloc=0.0D0
5290       do i=loc_start,loc_end
5291         costtab(i+1) =dcos(theta(i+1))
5292         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5293         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5294         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5295         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5296         cosfac=dsqrt(cosfac2)
5297         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5298         sinfac=dsqrt(sinfac2)
5299         it=itype(i)
5300         if (it.eq.10) goto 1
5301 c
5302 C  Compute the axes of tghe local cartesian coordinates system; store in
5303 c   x_prime, y_prime and z_prime
5304 c
5305         do j=1,3
5306           x_prime(j) = 0.00
5307           y_prime(j) = 0.00
5308           z_prime(j) = 0.00
5309         enddo
5310 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5311 C     &   dc_norm(3,i+nres)
5312         do j = 1,3
5313           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5314           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5315         enddo
5316         do j = 1,3
5317           z_prime(j) = -uz(j,i-1)
5318         enddo
5319 c       write (2,*) "i",i
5320 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5321 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5322 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5323 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5324 c      & " xy",scalar(x_prime(1),y_prime(1)),
5325 c      & " xz",scalar(x_prime(1),z_prime(1)),
5326 c      & " yy",scalar(y_prime(1),y_prime(1)),
5327 c      & " yz",scalar(y_prime(1),z_prime(1)),
5328 c      & " zz",scalar(z_prime(1),z_prime(1))
5329 c
5330 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5331 C to local coordinate system. Store in xx, yy, zz.
5332 c
5333         xx=0.0d0
5334         yy=0.0d0
5335         zz=0.0d0
5336         do j = 1,3
5337           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5338           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5339           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5340         enddo
5341
5342         xxtab(i)=xx
5343         yytab(i)=yy
5344         zztab(i)=zz
5345 C
5346 C Compute the energy of the ith side cbain
5347 C
5348 c        write (2,*) "xx",xx," yy",yy," zz",zz
5349         it=itype(i)
5350         do j = 1,65
5351           x(j) = sc_parmin(j,it)
5352         enddo
5353 #ifdef CHECK_COORD
5354 Cc diagnostics - remove later
5355         xx1 = dcos(alph(2))
5356         yy1 = dsin(alph(2))*dcos(omeg(2))
5357         zz1 = -dsin(alph(2))*dsin(omeg(2))
5358         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5359      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5360      &    xx1,yy1,zz1
5361 C,"  --- ", xx_w,yy_w,zz_w
5362 c end diagnostics
5363 #endif
5364         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5365      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5366      &   + x(10)*yy*zz
5367         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5368      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5369      & + x(20)*yy*zz
5370         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5371      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5372      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5373      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5374      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5375      &  +x(40)*xx*yy*zz
5376         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5377      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5378      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5379      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5380      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5381      &  +x(60)*xx*yy*zz
5382         dsc_i   = 0.743d0+x(61)
5383         dp2_i   = 1.9d0+x(62)
5384         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5385      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5386         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5387      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5388         s1=(1+x(63))/(0.1d0 + dscp1)
5389         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5390         s2=(1+x(65))/(0.1d0 + dscp2)
5391         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5392         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5393      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5394 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5395 c     &   sumene4,
5396 c     &   dscp1,dscp2,sumene
5397 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5398         escloc = escloc + sumene
5399 c        write (2,*) "i",i," escloc",sumene,escloc
5400 #ifdef DEBUG
5401 C
5402 C This section to check the numerical derivatives of the energy of ith side
5403 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5404 C #define DEBUG in the code to turn it on.
5405 C
5406         write (2,*) "sumene               =",sumene
5407         aincr=1.0d-7
5408         xxsave=xx
5409         xx=xx+aincr
5410         write (2,*) xx,yy,zz
5411         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5412         de_dxx_num=(sumenep-sumene)/aincr
5413         xx=xxsave
5414         write (2,*) "xx+ sumene from enesc=",sumenep
5415         yysave=yy
5416         yy=yy+aincr
5417         write (2,*) xx,yy,zz
5418         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5419         de_dyy_num=(sumenep-sumene)/aincr
5420         yy=yysave
5421         write (2,*) "yy+ sumene from enesc=",sumenep
5422         zzsave=zz
5423         zz=zz+aincr
5424         write (2,*) xx,yy,zz
5425         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5426         de_dzz_num=(sumenep-sumene)/aincr
5427         zz=zzsave
5428         write (2,*) "zz+ sumene from enesc=",sumenep
5429         costsave=cost2tab(i+1)
5430         sintsave=sint2tab(i+1)
5431         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5432         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5433         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5434         de_dt_num=(sumenep-sumene)/aincr
5435         write (2,*) " t+ sumene from enesc=",sumenep
5436         cost2tab(i+1)=costsave
5437         sint2tab(i+1)=sintsave
5438 C End of diagnostics section.
5439 #endif
5440 C
5441 C Compute the gradient of esc
5442 C
5443         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5444         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5445         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5446         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5447         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5448         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5449         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5450         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5451         pom1=(sumene3*sint2tab(i+1)+sumene1)
5452      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5453         pom2=(sumene4*cost2tab(i+1)+sumene2)
5454      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5455         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5456         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5457      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5458      &  +x(40)*yy*zz
5459         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5460         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5461      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5462      &  +x(60)*yy*zz
5463         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5464      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5465      &        +(pom1+pom2)*pom_dx
5466 #ifdef DEBUG
5467         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5468 #endif
5469 C
5470         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5471         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5472      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5473      &  +x(40)*xx*zz
5474         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5475         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5476      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5477      &  +x(59)*zz**2 +x(60)*xx*zz
5478         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5479      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5480      &        +(pom1-pom2)*pom_dy
5481 #ifdef DEBUG
5482         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5483 #endif
5484 C
5485         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5486      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5487      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5488      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5489      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5490      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5491      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5492      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5493 #ifdef DEBUG
5494         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5495 #endif
5496 C
5497         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5498      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5499      &  +pom1*pom_dt1+pom2*pom_dt2
5500 #ifdef DEBUG
5501         write(2,*), "de_dt = ", de_dt,de_dt_num
5502 #endif
5503 c
5504 C
5505        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5506        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5507        cosfac2xx=cosfac2*xx
5508        sinfac2yy=sinfac2*yy
5509        do k = 1,3
5510          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5511      &      vbld_inv(i+1)
5512          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5513      &      vbld_inv(i)
5514          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5515          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5516 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5517 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5518 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5519 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5520          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5521          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5522          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5523          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5524          dZZ_Ci1(k)=0.0d0
5525          dZZ_Ci(k)=0.0d0
5526          do j=1,3
5527            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5528            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5529          enddo
5530
5531          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5532          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5533          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5534 c
5535          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5536          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5537        enddo
5538
5539        do k=1,3
5540          dXX_Ctab(k,i)=dXX_Ci(k)
5541          dXX_C1tab(k,i)=dXX_Ci1(k)
5542          dYY_Ctab(k,i)=dYY_Ci(k)
5543          dYY_C1tab(k,i)=dYY_Ci1(k)
5544          dZZ_Ctab(k,i)=dZZ_Ci(k)
5545          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5546          dXX_XYZtab(k,i)=dXX_XYZ(k)
5547          dYY_XYZtab(k,i)=dYY_XYZ(k)
5548          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5549        enddo
5550
5551        do k = 1,3
5552 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5553 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5554 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5555 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5556 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5557 c     &    dt_dci(k)
5558 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5559 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5560          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5561      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5562          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5563      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5564          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5565      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5566        enddo
5567 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5568 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5569
5570 C to check gradient call subroutine check_grad
5571
5572     1 continue
5573       enddo
5574       return
5575       end
5576 c------------------------------------------------------------------------------
5577       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5578       implicit none
5579       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5580      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5581       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5582      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5583      &   + x(10)*yy*zz
5584       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5585      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5586      & + x(20)*yy*zz
5587       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5588      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5589      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5590      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5591      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5592      &  +x(40)*xx*yy*zz
5593       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5594      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5595      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5596      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5597      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5598      &  +x(60)*xx*yy*zz
5599       dsc_i   = 0.743d0+x(61)
5600       dp2_i   = 1.9d0+x(62)
5601       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5602      &          *(xx*cost2+yy*sint2))
5603       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5604      &          *(xx*cost2-yy*sint2))
5605       s1=(1+x(63))/(0.1d0 + dscp1)
5606       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5607       s2=(1+x(65))/(0.1d0 + dscp2)
5608       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5609       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5610      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5611       enesc=sumene
5612       return
5613       end
5614 #endif
5615 c------------------------------------------------------------------------------
5616       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5617 C
5618 C This procedure calculates two-body contact function g(rij) and its derivative:
5619 C
5620 C           eps0ij                                     !       x < -1
5621 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5622 C            0                                         !       x > 1
5623 C
5624 C where x=(rij-r0ij)/delta
5625 C
5626 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5627 C
5628       implicit none
5629       double precision rij,r0ij,eps0ij,fcont,fprimcont
5630       double precision x,x2,x4,delta
5631 c     delta=0.02D0*r0ij
5632 c      delta=0.2D0*r0ij
5633       x=(rij-r0ij)/delta
5634       if (x.lt.-1.0D0) then
5635         fcont=eps0ij
5636         fprimcont=0.0D0
5637       else if (x.le.1.0D0) then
5638         x2=x*x
5639         x4=x2*x2
5640         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5641         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5642       else
5643         fcont=0.0D0
5644         fprimcont=0.0D0
5645       endif
5646       return
5647       end
5648 c------------------------------------------------------------------------------
5649       subroutine splinthet(theti,delta,ss,ssder)
5650       implicit real*8 (a-h,o-z)
5651       include 'DIMENSIONS'
5652       include 'COMMON.VAR'
5653       include 'COMMON.GEO'
5654       thetup=pi-delta
5655       thetlow=delta
5656       if (theti.gt.pipol) then
5657         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5658       else
5659         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5660         ssder=-ssder
5661       endif
5662       return
5663       end
5664 c------------------------------------------------------------------------------
5665       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5666       implicit none
5667       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5668       double precision ksi,ksi2,ksi3,a1,a2,a3
5669       a1=fprim0*delta/(f1-f0)
5670       a2=3.0d0-2.0d0*a1
5671       a3=a1-2.0d0
5672       ksi=(x-x0)/delta
5673       ksi2=ksi*ksi
5674       ksi3=ksi2*ksi
5675       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5676       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5677       return
5678       end
5679 c------------------------------------------------------------------------------
5680       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5681       implicit none
5682       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5683       double precision ksi,ksi2,ksi3,a1,a2,a3
5684       ksi=(x-x0)/delta
5685       ksi2=ksi*ksi
5686       ksi3=ksi2*ksi
5687       a1=fprim0x*delta
5688       a2=3*(f1x-f0x)-2*fprim0x*delta
5689       a3=fprim0x*delta-2*(f1x-f0x)
5690       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5691       return
5692       end
5693 C-----------------------------------------------------------------------------
5694 #ifdef CRYST_TOR
5695 C-----------------------------------------------------------------------------
5696       subroutine etor(etors,edihcnstr)
5697       implicit real*8 (a-h,o-z)
5698       include 'DIMENSIONS'
5699       include 'COMMON.VAR'
5700       include 'COMMON.GEO'
5701       include 'COMMON.LOCAL'
5702       include 'COMMON.TORSION'
5703       include 'COMMON.INTERACT'
5704       include 'COMMON.DERIV'
5705       include 'COMMON.CHAIN'
5706       include 'COMMON.NAMES'
5707       include 'COMMON.IOUNITS'
5708       include 'COMMON.FFIELD'
5709       include 'COMMON.TORCNSTR'
5710       include 'COMMON.CONTROL'
5711       logical lprn
5712 C Set lprn=.true. for debugging
5713       lprn=.false.
5714 c      lprn=.true.
5715       etors=0.0D0
5716       do i=iphi_start,iphi_end
5717       etors_ii=0.0D0
5718         itori=itortyp(itype(i-2))
5719         itori1=itortyp(itype(i-1))
5720         phii=phi(i)
5721         gloci=0.0D0
5722 C Proline-Proline pair is a special case...
5723         if (itori.eq.3 .and. itori1.eq.3) then
5724           if (phii.gt.-dwapi3) then
5725             cosphi=dcos(3*phii)
5726             fac=1.0D0/(1.0D0-cosphi)
5727             etorsi=v1(1,3,3)*fac
5728             etorsi=etorsi+etorsi
5729             etors=etors+etorsi-v1(1,3,3)
5730             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5731             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5732           endif
5733           do j=1,3
5734             v1ij=v1(j+1,itori,itori1)
5735             v2ij=v2(j+1,itori,itori1)
5736             cosphi=dcos(j*phii)
5737             sinphi=dsin(j*phii)
5738             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5739             if (energy_dec) etors_ii=etors_ii+
5740      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5741             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5742           enddo
5743         else
5744           do j=1,nterm_old
5745             v1ij=v1(j,itori,itori1)
5746             v2ij=v2(j,itori,itori1)
5747             cosphi=dcos(j*phii)
5748             sinphi=dsin(j*phii)
5749             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5750             if (energy_dec) etors_ii=etors_ii+
5751      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5752             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5753           enddo
5754         endif
5755         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5756      &        'etor',i,etors_ii
5757         if (lprn)
5758      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5759      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5760      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5761         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5762         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5763       enddo
5764 ! 6/20/98 - dihedral angle constraints
5765       edihcnstr=0.0d0
5766       do i=1,ndih_constr
5767         itori=idih_constr(i)
5768         phii=phi(itori)
5769         difi=phii-phi0(i)
5770         if (difi.gt.drange(i)) then
5771           difi=difi-drange(i)
5772           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5773           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5774         else if (difi.lt.-drange(i)) then
5775           difi=difi+drange(i)
5776           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5777           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5778         endif
5779 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5780 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5781       enddo
5782 !      write (iout,*) 'edihcnstr',edihcnstr
5783       return
5784       end
5785 c------------------------------------------------------------------------------
5786       subroutine etor_d(etors_d)
5787       etors_d=0.0d0
5788       return
5789       end
5790 c----------------------------------------------------------------------------
5791 #else
5792       subroutine etor(etors,edihcnstr)
5793       implicit real*8 (a-h,o-z)
5794       include 'DIMENSIONS'
5795       include 'COMMON.VAR'
5796       include 'COMMON.GEO'
5797       include 'COMMON.LOCAL'
5798       include 'COMMON.TORSION'
5799       include 'COMMON.INTERACT'
5800       include 'COMMON.DERIV'
5801       include 'COMMON.CHAIN'
5802       include 'COMMON.NAMES'
5803       include 'COMMON.IOUNITS'
5804       include 'COMMON.FFIELD'
5805       include 'COMMON.TORCNSTR'
5806       include 'COMMON.CONTROL'
5807       logical lprn
5808 C Set lprn=.true. for debugging
5809       lprn=.false.
5810 c     lprn=.true.
5811       etors=0.0D0
5812       do i=iphi_start,iphi_end
5813       etors_ii=0.0D0
5814         itori=itortyp(itype(i-2))
5815         itori1=itortyp(itype(i-1))
5816         phii=phi(i)
5817         gloci=0.0D0
5818 C Regular cosine and sine terms
5819         do j=1,nterm(itori,itori1)
5820           v1ij=v1(j,itori,itori1)
5821           v2ij=v2(j,itori,itori1)
5822           cosphi=dcos(j*phii)
5823           sinphi=dsin(j*phii)
5824           etors=etors+v1ij*cosphi+v2ij*sinphi
5825           if (energy_dec) etors_ii=etors_ii+
5826      &                v1ij*cosphi+v2ij*sinphi
5827           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5828         enddo
5829 C Lorentz terms
5830 C                         v1
5831 C  E = SUM ----------------------------------- - v1
5832 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5833 C
5834         cosphi=dcos(0.5d0*phii)
5835         sinphi=dsin(0.5d0*phii)
5836         do j=1,nlor(itori,itori1)
5837           vl1ij=vlor1(j,itori,itori1)
5838           vl2ij=vlor2(j,itori,itori1)
5839           vl3ij=vlor3(j,itori,itori1)
5840           pom=vl2ij*cosphi+vl3ij*sinphi
5841           pom1=1.0d0/(pom*pom+1.0d0)
5842           etors=etors+vl1ij*pom1
5843           if (energy_dec) etors_ii=etors_ii+
5844      &                vl1ij*pom1
5845           pom=-pom*pom1*pom1
5846           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5847         enddo
5848 C Subtract the constant term
5849         etors=etors-v0(itori,itori1)
5850           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5851      &         'etor',i,etors_ii-v0(itori,itori1)
5852         if (lprn)
5853      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5854      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5855      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5856         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5857 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5858       enddo
5859 ! 6/20/98 - dihedral angle constraints
5860       edihcnstr=0.0d0
5861 c      do i=1,ndih_constr
5862       do i=idihconstr_start,idihconstr_end
5863         itori=idih_constr(i)
5864         phii=phi(itori)
5865         difi=pinorm(phii-phi0(i))
5866         if (difi.gt.drange(i)) then
5867           difi=difi-drange(i)
5868           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5869           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5870         else if (difi.lt.-drange(i)) then
5871           difi=difi+drange(i)
5872           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5873           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5874         else
5875           difi=0.0
5876         endif
5877 c        write (iout,*) "gloci", gloc(i-3,icg)
5878 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5879 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5880 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5881       enddo
5882 cd       write (iout,*) 'edihcnstr',edihcnstr
5883       return
5884       end
5885 c----------------------------------------------------------------------------
5886       subroutine etor_d(etors_d)
5887 C 6/23/01 Compute double torsional energy
5888       implicit real*8 (a-h,o-z)
5889       include 'DIMENSIONS'
5890       include 'COMMON.VAR'
5891       include 'COMMON.GEO'
5892       include 'COMMON.LOCAL'
5893       include 'COMMON.TORSION'
5894       include 'COMMON.INTERACT'
5895       include 'COMMON.DERIV'
5896       include 'COMMON.CHAIN'
5897       include 'COMMON.NAMES'
5898       include 'COMMON.IOUNITS'
5899       include 'COMMON.FFIELD'
5900       include 'COMMON.TORCNSTR'
5901       include 'COMMON.CONTROL'
5902       logical lprn
5903 C Set lprn=.true. for debugging
5904       lprn=.false.
5905 c     lprn=.true.
5906       etors_d=0.0D0
5907       do i=iphid_start,iphid_end
5908         etors_d_ii=0.0D0
5909         itori=itortyp(itype(i-2))
5910         itori1=itortyp(itype(i-1))
5911         itori2=itortyp(itype(i))
5912         phii=phi(i)
5913         phii1=phi(i+1)
5914         gloci1=0.0D0
5915         gloci2=0.0D0
5916         do j=1,ntermd_1(itori,itori1,itori2)
5917           v1cij=v1c(1,j,itori,itori1,itori2)
5918           v1sij=v1s(1,j,itori,itori1,itori2)
5919           v2cij=v1c(2,j,itori,itori1,itori2)
5920           v2sij=v1s(2,j,itori,itori1,itori2)
5921           cosphi1=dcos(j*phii)
5922           sinphi1=dsin(j*phii)
5923           cosphi2=dcos(j*phii1)
5924           sinphi2=dsin(j*phii1)
5925           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5926      &     v2cij*cosphi2+v2sij*sinphi2
5927           if (energy_dec) etors_d_ii=etors_d_ii+
5928      &     v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
5929           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5930           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5931         enddo
5932         do k=2,ntermd_2(itori,itori1,itori2)
5933           do l=1,k-1
5934             v1cdij = v2c(k,l,itori,itori1,itori2)
5935             v2cdij = v2c(l,k,itori,itori1,itori2)
5936             v1sdij = v2s(k,l,itori,itori1,itori2)
5937             v2sdij = v2s(l,k,itori,itori1,itori2)
5938             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5939             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5940             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5941             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5942             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5943      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5944             if (energy_dec) etors_d_ii=etors_d_ii+
5945      &        v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5946      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5947             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5948      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5949             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5950      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5951           enddo
5952         enddo
5953         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5954      &        'etor_d',i,etors_d_ii
5955         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5956         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5957 c        write (iout,*) "gloci", gloc(i-3,icg)
5958       enddo
5959       return
5960       end
5961 #endif
5962 c------------------------------------------------------------------------------
5963       subroutine eback_sc_corr(esccor)
5964 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5965 c        conformational states; temporarily implemented as differences
5966 c        between UNRES torsional potentials (dependent on three types of
5967 c        residues) and the torsional potentials dependent on all 20 types
5968 c        of residues computed from AM1  energy surfaces of terminally-blocked
5969 c        amino-acid residues.
5970       implicit real*8 (a-h,o-z)
5971       include 'DIMENSIONS'
5972       include 'COMMON.VAR'
5973       include 'COMMON.GEO'
5974       include 'COMMON.LOCAL'
5975       include 'COMMON.TORSION'
5976       include 'COMMON.SCCOR'
5977       include 'COMMON.INTERACT'
5978       include 'COMMON.DERIV'
5979       include 'COMMON.CHAIN'
5980       include 'COMMON.NAMES'
5981       include 'COMMON.IOUNITS'
5982       include 'COMMON.FFIELD'
5983       include 'COMMON.CONTROL'
5984       logical lprn
5985 C Set lprn=.true. for debugging
5986       lprn=.false.
5987 c      lprn=.true.
5988 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5989       esccor=0.0D0
5990       do i=itau_start,itau_end
5991 C        do i=42,42
5992
5993         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5994         isccori=isccortyp(itype(i-2))
5995         isccori1=isccortyp(itype(i-1))
5996         phii=phi(i)
5997
5998 cccc  Added 9 May 2012
5999 cc Tauangle is torsional engle depending on the value of first digit
6000 c(see comment below)
6001 cc Omicron is flat angle depending on the value of first digit
6002 c(see comment below)
6003 C        print *,i,tauangle(1,i)
6004
6005         do intertyp=1,3 !intertyp
6006          esccor_ii=0.0D0
6007 cc Added 09 May 2012 (Adasko)
6008 cc  Intertyp means interaction type of backbone mainchain correlation:
6009 c   1 = SC...Ca...Ca...Ca
6010 c   2 = Ca...Ca...Ca...SC
6011 c   3 = SC...Ca...Ca...SCi
6012         gloci=0.0D0
6013         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6014      &      (itype(i-1).eq.10).or.(itype(i-2).eq.21).or.
6015      &      (itype(i-1).eq.21)))
6016      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6017      &     .or.(itype(i-2).eq.21)))
6018      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6019      &      (itype(i-1).eq.21)))) cycle
6020         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.21)) cycle
6021         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.21))
6022      & cycle
6023         do j=1,nterm_sccor(isccori,isccori1)
6024           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6025           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6026           cosphi=dcos(j*tauangle(intertyp,i))
6027           sinphi=dsin(j*tauangle(intertyp,i))
6028           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
6029           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6030           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6031         enddo
6032           if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)')
6033      &         'esccor',i,intertyp,esccor_ii
6034 C        print *,i,tauangle(1,i),gloci
6035         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6036 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6037 c     &gloc_sc(intertyp,i-3,icg)
6038         if (lprn)
6039      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6040      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6041      &  (v1sccor(j,intertyp,itori,itori1),j=1,6)
6042      & ,(v2sccor(j,intertyp,itori,itori1),j=1,6)
6043         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6044        enddo !intertyp
6045       enddo
6046 c        do i=1,nres
6047 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc_sc(2,i,icg),
6048 c     &   gloc_sc(3,i,icg)
6049 c        enddo
6050       return
6051       end
6052 c----------------------------------------------------------------------------
6053       subroutine multibody(ecorr)
6054 C This subroutine calculates multi-body contributions to energy following
6055 C the idea of Skolnick et al. If side chains I and J make a contact and
6056 C at the same time side chains I+1 and J+1 make a contact, an extra
6057 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6058       implicit real*8 (a-h,o-z)
6059       include 'DIMENSIONS'
6060       include 'COMMON.IOUNITS'
6061       include 'COMMON.DERIV'
6062       include 'COMMON.INTERACT'
6063       include 'COMMON.CONTACTS'
6064       double precision gx(3),gx1(3)
6065       logical lprn
6066
6067 C Set lprn=.true. for debugging
6068       lprn=.false.
6069
6070       if (lprn) then
6071         write (iout,'(a)') 'Contact function values:'
6072         do i=nnt,nct-2
6073           write (iout,'(i2,20(1x,i2,f10.5))')
6074      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6075         enddo
6076       endif
6077       ecorr=0.0D0
6078       do i=nnt,nct
6079         do j=1,3
6080           gradcorr(j,i)=0.0D0
6081           gradxorr(j,i)=0.0D0
6082         enddo
6083       enddo
6084       do i=nnt,nct-2
6085
6086         DO ISHIFT = 3,4
6087
6088         i1=i+ishift
6089         num_conti=num_cont(i)
6090         num_conti1=num_cont(i1)
6091         do jj=1,num_conti
6092           j=jcont(jj,i)
6093           do kk=1,num_conti1
6094             j1=jcont(kk,i1)
6095             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6096 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6097 cd   &                   ' ishift=',ishift
6098 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6099 C The system gains extra energy.
6100               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6101             endif   ! j1==j+-ishift
6102           enddo     ! kk
6103         enddo       ! jj
6104
6105         ENDDO ! ISHIFT
6106
6107       enddo         ! i
6108       return
6109       end
6110 c------------------------------------------------------------------------------
6111       double precision function esccorr(i,j,k,l,jj,kk)
6112       implicit real*8 (a-h,o-z)
6113       include 'DIMENSIONS'
6114       include 'COMMON.IOUNITS'
6115       include 'COMMON.DERIV'
6116       include 'COMMON.INTERACT'
6117       include 'COMMON.CONTACTS'
6118       double precision gx(3),gx1(3)
6119       logical lprn
6120       lprn=.false.
6121       eij=facont(jj,i)
6122       ekl=facont(kk,k)
6123 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6124 C Calculate the multi-body contribution to energy.
6125 C Calculate multi-body contributions to the gradient.
6126 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6127 cd   & k,l,(gacont(m,kk,k),m=1,3)
6128       do m=1,3
6129         gx(m) =ekl*gacont(m,jj,i)
6130         gx1(m)=eij*gacont(m,kk,k)
6131         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6132         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6133         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6134         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6135       enddo
6136       do m=i,j-1
6137         do ll=1,3
6138           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6139         enddo
6140       enddo
6141       do m=k,l-1
6142         do ll=1,3
6143           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6144         enddo
6145       enddo
6146       esccorr=-eij*ekl
6147       return
6148       end
6149 c------------------------------------------------------------------------------
6150       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6151 C This subroutine calculates multi-body contributions to hydrogen-bonding
6152       implicit real*8 (a-h,o-z)
6153       include 'DIMENSIONS'
6154       include 'COMMON.IOUNITS'
6155 #ifdef MPI
6156       include "mpif.h"
6157       parameter (max_cont=maxconts)
6158       parameter (max_dim=26)
6159       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6160       double precision zapas(max_dim,maxconts,max_fg_procs),
6161      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6162       common /przechowalnia/ zapas
6163       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6164      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6165 #endif
6166       include 'COMMON.SETUP'
6167       include 'COMMON.FFIELD'
6168       include 'COMMON.DERIV'
6169       include 'COMMON.INTERACT'
6170       include 'COMMON.CONTACTS'
6171       include 'COMMON.CONTROL'
6172       include 'COMMON.LOCAL'
6173       double precision gx(3),gx1(3),time00
6174       logical lprn,ldone
6175
6176 C Set lprn=.true. for debugging
6177       lprn=.false.
6178 #ifdef MPI
6179       n_corr=0
6180       n_corr1=0
6181       if (nfgtasks.le.1) goto 30
6182       if (lprn) then
6183         write (iout,'(a)') 'Contact function values before RECEIVE:'
6184         do i=nnt,nct-2
6185           write (iout,'(2i3,50(1x,i2,f5.2))')
6186      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6187      &    j=1,num_cont_hb(i))
6188         enddo
6189       endif
6190       call flush(iout)
6191       do i=1,ntask_cont_from
6192         ncont_recv(i)=0
6193       enddo
6194       do i=1,ntask_cont_to
6195         ncont_sent(i)=0
6196       enddo
6197 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6198 c     & ntask_cont_to
6199 C Make the list of contacts to send to send to other procesors
6200 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6201 c      call flush(iout)
6202       do i=iturn3_start,iturn3_end
6203 c        write (iout,*) "make contact list turn3",i," num_cont",
6204 c     &    num_cont_hb(i)
6205         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6206       enddo
6207       do i=iturn4_start,iturn4_end
6208 c        write (iout,*) "make contact list turn4",i," num_cont",
6209 c     &   num_cont_hb(i)
6210         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6211       enddo
6212       do ii=1,nat_sent
6213         i=iat_sent(ii)
6214 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6215 c     &    num_cont_hb(i)
6216         do j=1,num_cont_hb(i)
6217         do k=1,4
6218           jjc=jcont_hb(j,i)
6219           iproc=iint_sent_local(k,jjc,ii)
6220 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6221           if (iproc.gt.0) then
6222             ncont_sent(iproc)=ncont_sent(iproc)+1
6223             nn=ncont_sent(iproc)
6224             zapas(1,nn,iproc)=i
6225             zapas(2,nn,iproc)=jjc
6226             zapas(3,nn,iproc)=facont_hb(j,i)
6227             zapas(4,nn,iproc)=ees0p(j,i)
6228             zapas(5,nn,iproc)=ees0m(j,i)
6229             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6230             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6231             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6232             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6233             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6234             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6235             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6236             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6237             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6238             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6239             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6240             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6241             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6242             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6243             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6244             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6245             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6246             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6247             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6248             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6249             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6250           endif
6251         enddo
6252         enddo
6253       enddo
6254       if (lprn) then
6255       write (iout,*)
6256      &  "Numbers of contacts to be sent to other processors",
6257      &  (ncont_sent(i),i=1,ntask_cont_to)
6258       write (iout,*) "Contacts sent"
6259       do ii=1,ntask_cont_to
6260         nn=ncont_sent(ii)
6261         iproc=itask_cont_to(ii)
6262         write (iout,*) nn," contacts to processor",iproc,
6263      &   " of CONT_TO_COMM group"
6264         do i=1,nn
6265           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6266         enddo
6267       enddo
6268       call flush(iout)
6269       endif
6270       CorrelType=477
6271       CorrelID=fg_rank+1
6272       CorrelType1=478
6273       CorrelID1=nfgtasks+fg_rank+1
6274       ireq=0
6275 C Receive the numbers of needed contacts from other processors
6276       do ii=1,ntask_cont_from
6277         iproc=itask_cont_from(ii)
6278         ireq=ireq+1
6279         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6280      &    FG_COMM,req(ireq),IERR)
6281       enddo
6282 c      write (iout,*) "IRECV ended"
6283 c      call flush(iout)
6284 C Send the number of contacts needed by other processors
6285       do ii=1,ntask_cont_to
6286         iproc=itask_cont_to(ii)
6287         ireq=ireq+1
6288         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6289      &    FG_COMM,req(ireq),IERR)
6290       enddo
6291 c      write (iout,*) "ISEND ended"
6292 c      write (iout,*) "number of requests (nn)",ireq
6293       call flush(iout)
6294       if (ireq.gt.0)
6295      &  call MPI_Waitall(ireq,req,status_array,ierr)
6296 c      write (iout,*)
6297 c     &  "Numbers of contacts to be received from other processors",
6298 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6299 c      call flush(iout)
6300 C Receive contacts
6301       ireq=0
6302       do ii=1,ntask_cont_from
6303         iproc=itask_cont_from(ii)
6304         nn=ncont_recv(ii)
6305 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6306 c     &   " of CONT_TO_COMM group"
6307         call flush(iout)
6308         if (nn.gt.0) then
6309           ireq=ireq+1
6310           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6311      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6312 c          write (iout,*) "ireq,req",ireq,req(ireq)
6313         endif
6314       enddo
6315 C Send the contacts to processors that need them
6316       do ii=1,ntask_cont_to
6317         iproc=itask_cont_to(ii)
6318         nn=ncont_sent(ii)
6319 c        write (iout,*) nn," contacts to processor",iproc,
6320 c     &   " of CONT_TO_COMM group"
6321         if (nn.gt.0) then
6322           ireq=ireq+1
6323           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6324      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6325 c          write (iout,*) "ireq,req",ireq,req(ireq)
6326 c          do i=1,nn
6327 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6328 c          enddo
6329         endif
6330       enddo
6331 c      write (iout,*) "number of requests (contacts)",ireq
6332 c      write (iout,*) "req",(req(i),i=1,4)
6333 c      call flush(iout)
6334       if (ireq.gt.0)
6335      & call MPI_Waitall(ireq,req,status_array,ierr)
6336       do iii=1,ntask_cont_from
6337         iproc=itask_cont_from(iii)
6338         nn=ncont_recv(iii)
6339         if (lprn) then
6340         write (iout,*) "Received",nn," contacts from processor",iproc,
6341      &   " of CONT_FROM_COMM group"
6342         call flush(iout)
6343         do i=1,nn
6344           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6345         enddo
6346         call flush(iout)
6347         endif
6348         do i=1,nn
6349           ii=zapas_recv(1,i,iii)
6350 c Flag the received contacts to prevent double-counting
6351           jj=-zapas_recv(2,i,iii)
6352 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6353 c          call flush(iout)
6354           nnn=num_cont_hb(ii)+1
6355           num_cont_hb(ii)=nnn
6356           jcont_hb(nnn,ii)=jj
6357           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6358           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6359           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6360           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6361           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6362           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6363           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6364           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6365           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6366           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6367           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6368           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6369           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6370           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6371           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6372           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6373           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6374           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6375           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6376           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6377           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6378           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6379           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6380           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6381         enddo
6382       enddo
6383       call flush(iout)
6384       if (lprn) then
6385         write (iout,'(a)') 'Contact function values after receive:'
6386         do i=nnt,nct-2
6387           write (iout,'(2i3,50(1x,i3,f5.2))')
6388      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6389      &    j=1,num_cont_hb(i))
6390         enddo
6391         call flush(iout)
6392       endif
6393    30 continue
6394 #endif
6395       if (lprn) then
6396         write (iout,'(a)') 'Contact function values:'
6397         do i=nnt,nct-2
6398           write (iout,'(2i3,50(1x,i3,f5.2))')
6399      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6400      &    j=1,num_cont_hb(i))
6401         enddo
6402       endif
6403       ecorr=0.0D0
6404 C Remove the loop below after debugging !!!
6405       do i=nnt,nct
6406         do j=1,3
6407           gradcorr(j,i)=0.0D0
6408           gradxorr(j,i)=0.0D0
6409         enddo
6410       enddo
6411 C Calculate the local-electrostatic correlation terms
6412       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6413         i1=i+1
6414         num_conti=num_cont_hb(i)
6415         num_conti1=num_cont_hb(i+1)
6416         do jj=1,num_conti
6417           j=jcont_hb(jj,i)
6418           jp=iabs(j)
6419           do kk=1,num_conti1
6420             j1=jcont_hb(kk,i1)
6421             jp1=iabs(j1)
6422 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6423 c     &         ' jj=',jj,' kk=',kk
6424             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6425      &          .or. j.lt.0 .and. j1.gt.0) .and.
6426      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6427 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6428 C The system gains extra energy.
6429               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6430               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6431      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6432               n_corr=n_corr+1
6433             else if (j1.eq.j) then
6434 C Contacts I-J and I-(J+1) occur simultaneously.
6435 C The system loses extra energy.
6436 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6437             endif
6438           enddo ! kk
6439           do kk=1,num_conti
6440             j1=jcont_hb(kk,i)
6441 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6442 c    &         ' jj=',jj,' kk=',kk
6443             if (j1.eq.j+1) then
6444 C Contacts I-J and (I+1)-J occur simultaneously.
6445 C The system loses extra energy.
6446 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6447             endif ! j1==j+1
6448           enddo ! kk
6449         enddo ! jj
6450       enddo ! i
6451       return
6452       end
6453 c------------------------------------------------------------------------------
6454       subroutine add_hb_contact(ii,jj,itask)
6455       implicit real*8 (a-h,o-z)
6456       include "DIMENSIONS"
6457       include "COMMON.IOUNITS"
6458       integer max_cont
6459       integer max_dim
6460       parameter (max_cont=maxconts)
6461       parameter (max_dim=26)
6462       include "COMMON.CONTACTS"
6463       double precision zapas(max_dim,maxconts,max_fg_procs),
6464      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6465       common /przechowalnia/ zapas
6466       integer i,j,ii,jj,iproc,itask(4),nn
6467 c      write (iout,*) "itask",itask
6468       do i=1,2
6469         iproc=itask(i)
6470         if (iproc.gt.0) then
6471           do j=1,num_cont_hb(ii)
6472             jjc=jcont_hb(j,ii)
6473 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6474             if (jjc.eq.jj) then
6475               ncont_sent(iproc)=ncont_sent(iproc)+1
6476               nn=ncont_sent(iproc)
6477               zapas(1,nn,iproc)=ii
6478               zapas(2,nn,iproc)=jjc
6479               zapas(3,nn,iproc)=facont_hb(j,ii)
6480               zapas(4,nn,iproc)=ees0p(j,ii)
6481               zapas(5,nn,iproc)=ees0m(j,ii)
6482               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6483               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6484               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6485               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6486               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6487               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6488               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6489               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6490               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6491               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6492               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6493               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6494               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6495               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6496               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6497               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6498               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6499               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6500               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6501               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6502               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6503               exit
6504             endif
6505           enddo
6506         endif
6507       enddo
6508       return
6509       end
6510 c------------------------------------------------------------------------------
6511       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6512      &  n_corr1)
6513 C This subroutine calculates multi-body contributions to hydrogen-bonding
6514       implicit real*8 (a-h,o-z)
6515       include 'DIMENSIONS'
6516       include 'COMMON.IOUNITS'
6517 #ifdef MPI
6518       include "mpif.h"
6519       parameter (max_cont=maxconts)
6520       parameter (max_dim=70)
6521       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6522       double precision zapas(max_dim,maxconts,max_fg_procs),
6523      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6524       common /przechowalnia/ zapas
6525       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6526      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6527 #endif
6528       include 'COMMON.SETUP'
6529       include 'COMMON.FFIELD'
6530       include 'COMMON.DERIV'
6531       include 'COMMON.LOCAL'
6532       include 'COMMON.INTERACT'
6533       include 'COMMON.CONTACTS'
6534       include 'COMMON.CHAIN'
6535       include 'COMMON.CONTROL'
6536       double precision gx(3),gx1(3)
6537       integer num_cont_hb_old(maxres)
6538       logical lprn,ldone
6539       double precision eello4,eello5,eelo6,eello_turn6
6540       external eello4,eello5,eello6,eello_turn6
6541 C Set lprn=.true. for debugging
6542       lprn=.false.
6543       eturn6=0.0d0
6544 #ifdef MPI
6545       do i=1,nres
6546         num_cont_hb_old(i)=num_cont_hb(i)
6547       enddo
6548       n_corr=0
6549       n_corr1=0
6550       if (nfgtasks.le.1) goto 30
6551       if (lprn) then
6552         write (iout,'(a)') 'Contact function values before RECEIVE:'
6553         do i=nnt,nct-2
6554           write (iout,'(2i3,50(1x,i2,f5.2))')
6555      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6556      &    j=1,num_cont_hb(i))
6557         enddo
6558       endif
6559       call flush(iout)
6560       do i=1,ntask_cont_from
6561         ncont_recv(i)=0
6562       enddo
6563       do i=1,ntask_cont_to
6564         ncont_sent(i)=0
6565       enddo
6566 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6567 c     & ntask_cont_to
6568 C Make the list of contacts to send to send to other procesors
6569       do i=iturn3_start,iturn3_end
6570 c        write (iout,*) "make contact list turn3",i," num_cont",
6571 c     &    num_cont_hb(i)
6572         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6573       enddo
6574       do i=iturn4_start,iturn4_end
6575 c        write (iout,*) "make contact list turn4",i," num_cont",
6576 c     &   num_cont_hb(i)
6577         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6578       enddo
6579       do ii=1,nat_sent
6580         i=iat_sent(ii)
6581 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6582 c     &    num_cont_hb(i)
6583         do j=1,num_cont_hb(i)
6584         do k=1,4
6585           jjc=jcont_hb(j,i)
6586           iproc=iint_sent_local(k,jjc,ii)
6587 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6588           if (iproc.ne.0) then
6589             ncont_sent(iproc)=ncont_sent(iproc)+1
6590             nn=ncont_sent(iproc)
6591             zapas(1,nn,iproc)=i
6592             zapas(2,nn,iproc)=jjc
6593             zapas(3,nn,iproc)=d_cont(j,i)
6594             ind=3
6595             do kk=1,3
6596               ind=ind+1
6597               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6598             enddo
6599             do kk=1,2
6600               do ll=1,2
6601                 ind=ind+1
6602                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6603               enddo
6604             enddo
6605             do jj=1,5
6606               do kk=1,3
6607                 do ll=1,2
6608                   do mm=1,2
6609                     ind=ind+1
6610                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6611                   enddo
6612                 enddo
6613               enddo
6614             enddo
6615           endif
6616         enddo
6617         enddo
6618       enddo
6619       if (lprn) then
6620       write (iout,*)
6621      &  "Numbers of contacts to be sent to other processors",
6622      &  (ncont_sent(i),i=1,ntask_cont_to)
6623       write (iout,*) "Contacts sent"
6624       do ii=1,ntask_cont_to
6625         nn=ncont_sent(ii)
6626         iproc=itask_cont_to(ii)
6627         write (iout,*) nn," contacts to processor",iproc,
6628      &   " of CONT_TO_COMM group"
6629         do i=1,nn
6630           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6631         enddo
6632       enddo
6633       call flush(iout)
6634       endif
6635       CorrelType=477
6636       CorrelID=fg_rank+1
6637       CorrelType1=478
6638       CorrelID1=nfgtasks+fg_rank+1
6639       ireq=0
6640 C Receive the numbers of needed contacts from other processors
6641       do ii=1,ntask_cont_from
6642         iproc=itask_cont_from(ii)
6643         ireq=ireq+1
6644         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6645      &    FG_COMM,req(ireq),IERR)
6646       enddo
6647 c      write (iout,*) "IRECV ended"
6648 c      call flush(iout)
6649 C Send the number of contacts needed by other processors
6650       do ii=1,ntask_cont_to
6651         iproc=itask_cont_to(ii)
6652         ireq=ireq+1
6653         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6654      &    FG_COMM,req(ireq),IERR)
6655       enddo
6656 c      write (iout,*) "ISEND ended"
6657 c      write (iout,*) "number of requests (nn)",ireq
6658       call flush(iout)
6659       if (ireq.gt.0)
6660      &  call MPI_Waitall(ireq,req,status_array,ierr)
6661 c      write (iout,*)
6662 c     &  "Numbers of contacts to be received from other processors",
6663 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6664 c      call flush(iout)
6665 C Receive contacts
6666       ireq=0
6667       do ii=1,ntask_cont_from
6668         iproc=itask_cont_from(ii)
6669         nn=ncont_recv(ii)
6670 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6671 c     &   " of CONT_TO_COMM group"
6672         call flush(iout)
6673         if (nn.gt.0) then
6674           ireq=ireq+1
6675           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6676      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6677 c          write (iout,*) "ireq,req",ireq,req(ireq)
6678         endif
6679       enddo
6680 C Send the contacts to processors that need them
6681       do ii=1,ntask_cont_to
6682         iproc=itask_cont_to(ii)
6683         nn=ncont_sent(ii)
6684 c        write (iout,*) nn," contacts to processor",iproc,
6685 c     &   " of CONT_TO_COMM group"
6686         if (nn.gt.0) then
6687           ireq=ireq+1
6688           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6689      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6690 c          write (iout,*) "ireq,req",ireq,req(ireq)
6691 c          do i=1,nn
6692 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6693 c          enddo
6694         endif
6695       enddo
6696 c      write (iout,*) "number of requests (contacts)",ireq
6697 c      write (iout,*) "req",(req(i),i=1,4)
6698 c      call flush(iout)
6699       if (ireq.gt.0)
6700      & call MPI_Waitall(ireq,req,status_array,ierr)
6701       do iii=1,ntask_cont_from
6702         iproc=itask_cont_from(iii)
6703         nn=ncont_recv(iii)
6704         if (lprn) then
6705         write (iout,*) "Received",nn," contacts from processor",iproc,
6706      &   " of CONT_FROM_COMM group"
6707         call flush(iout)
6708         do i=1,nn
6709           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6710         enddo
6711         call flush(iout)
6712         endif
6713         do i=1,nn
6714           ii=zapas_recv(1,i,iii)
6715 c Flag the received contacts to prevent double-counting
6716           jj=-zapas_recv(2,i,iii)
6717 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6718 c          call flush(iout)
6719           nnn=num_cont_hb(ii)+1
6720           num_cont_hb(ii)=nnn
6721           jcont_hb(nnn,ii)=jj
6722           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6723           ind=3
6724           do kk=1,3
6725             ind=ind+1
6726             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6727           enddo
6728           do kk=1,2
6729             do ll=1,2
6730               ind=ind+1
6731               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6732             enddo
6733           enddo
6734           do jj=1,5
6735             do kk=1,3
6736               do ll=1,2
6737                 do mm=1,2
6738                   ind=ind+1
6739                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6740                 enddo
6741               enddo
6742             enddo
6743           enddo
6744         enddo
6745       enddo
6746       call flush(iout)
6747       if (lprn) then
6748         write (iout,'(a)') 'Contact function values after receive:'
6749         do i=nnt,nct-2
6750           write (iout,'(2i3,50(1x,i3,5f6.3))')
6751      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6752      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6753         enddo
6754         call flush(iout)
6755       endif
6756    30 continue
6757 #endif
6758       if (lprn) then
6759         write (iout,'(a)') 'Contact function values:'
6760         do i=nnt,nct-2
6761           write (iout,'(2i3,50(1x,i2,5f6.3))')
6762      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6763      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6764         enddo
6765       endif
6766       ecorr=0.0D0
6767       ecorr5=0.0d0
6768       ecorr6=0.0d0
6769 C Remove the loop below after debugging !!!
6770       do i=nnt,nct
6771         do j=1,3
6772           gradcorr(j,i)=0.0D0
6773           gradxorr(j,i)=0.0D0
6774         enddo
6775       enddo
6776 C Calculate the dipole-dipole interaction energies
6777       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6778       do i=iatel_s,iatel_e+1
6779         num_conti=num_cont_hb(i)
6780         do jj=1,num_conti
6781           j=jcont_hb(jj,i)
6782 #ifdef MOMENT
6783           call dipole(i,j,jj)
6784 #endif
6785         enddo
6786       enddo
6787       endif
6788 C Calculate the local-electrostatic correlation terms
6789 c                write (iout,*) "gradcorr5 in eello5 before loop"
6790 c                do iii=1,nres
6791 c                  write (iout,'(i5,3f10.5)')
6792 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6793 c                enddo
6794       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6795 c        write (iout,*) "corr loop i",i
6796         i1=i+1
6797         num_conti=num_cont_hb(i)
6798         num_conti1=num_cont_hb(i+1)
6799         do jj=1,num_conti
6800           j=jcont_hb(jj,i)
6801           jp=iabs(j)
6802           do kk=1,num_conti1
6803             j1=jcont_hb(kk,i1)
6804             jp1=iabs(j1)
6805 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6806 c     &         ' jj=',jj,' kk=',kk
6807 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6808             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6809      &          .or. j.lt.0 .and. j1.gt.0) .and.
6810      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6811 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6812 C The system gains extra energy.
6813               n_corr=n_corr+1
6814               sqd1=dsqrt(d_cont(jj,i))
6815               sqd2=dsqrt(d_cont(kk,i1))
6816               sred_geom = sqd1*sqd2
6817               IF (sred_geom.lt.cutoff_corr) THEN
6818                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6819      &            ekont,fprimcont)
6820 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6821 cd     &         ' jj=',jj,' kk=',kk
6822                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6823                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6824                 do l=1,3
6825                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6826                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6827                 enddo
6828                 n_corr1=n_corr1+1
6829 cd               write (iout,*) 'sred_geom=',sred_geom,
6830 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6831 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6832 cd               write (iout,*) "g_contij",g_contij
6833 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6834 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6835                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6836                 if (wcorr4.gt.0.0d0)
6837      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6838                   if (energy_dec.and.wcorr4.gt.0.0d0)
6839      1                 write (iout,'(a6,4i5,0pf7.3)')
6840      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6841 c                write (iout,*) "gradcorr5 before eello5"
6842 c                do iii=1,nres
6843 c                  write (iout,'(i5,3f10.5)')
6844 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6845 c                enddo
6846                 if (wcorr5.gt.0.0d0)
6847      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6848 c                write (iout,*) "gradcorr5 after eello5"
6849 c                do iii=1,nres
6850 c                  write (iout,'(i5,3f10.5)')
6851 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6852 c                enddo
6853                   if (energy_dec.and.wcorr5.gt.0.0d0)
6854      1                 write (iout,'(a6,4i5,0pf7.3)')
6855      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6856 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6857 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6858                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6859      &               .or. wturn6.eq.0.0d0))then
6860 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6861                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6862                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6863      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6864 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6865 cd     &            'ecorr6=',ecorr6
6866 cd                write (iout,'(4e15.5)') sred_geom,
6867 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6868 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6869 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6870                 else if (wturn6.gt.0.0d0
6871      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6872 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6873                   eturn6=eturn6+eello_turn6(i,jj,kk)
6874                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6875      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6876 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6877                 endif
6878               ENDIF
6879 1111          continue
6880             endif
6881           enddo ! kk
6882         enddo ! jj
6883       enddo ! i
6884       do i=1,nres
6885         num_cont_hb(i)=num_cont_hb_old(i)
6886       enddo
6887 c                write (iout,*) "gradcorr5 in eello5"
6888 c                do iii=1,nres
6889 c                  write (iout,'(i5,3f10.5)')
6890 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6891 c                enddo
6892       return
6893       end
6894 c------------------------------------------------------------------------------
6895       subroutine add_hb_contact_eello(ii,jj,itask)
6896       implicit real*8 (a-h,o-z)
6897       include "DIMENSIONS"
6898       include "COMMON.IOUNITS"
6899       integer max_cont
6900       integer max_dim
6901       parameter (max_cont=maxconts)
6902       parameter (max_dim=70)
6903       include "COMMON.CONTACTS"
6904       double precision zapas(max_dim,maxconts,max_fg_procs),
6905      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6906       common /przechowalnia/ zapas
6907       integer i,j,ii,jj,iproc,itask(4),nn
6908 c      write (iout,*) "itask",itask
6909       do i=1,2
6910         iproc=itask(i)
6911         if (iproc.gt.0) then
6912           do j=1,num_cont_hb(ii)
6913             jjc=jcont_hb(j,ii)
6914 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6915             if (jjc.eq.jj) then
6916               ncont_sent(iproc)=ncont_sent(iproc)+1
6917               nn=ncont_sent(iproc)
6918               zapas(1,nn,iproc)=ii
6919               zapas(2,nn,iproc)=jjc
6920               zapas(3,nn,iproc)=d_cont(j,ii)
6921               ind=3
6922               do kk=1,3
6923                 ind=ind+1
6924                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6925               enddo
6926               do kk=1,2
6927                 do ll=1,2
6928                   ind=ind+1
6929                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6930                 enddo
6931               enddo
6932               do jj=1,5
6933                 do kk=1,3
6934                   do ll=1,2
6935                     do mm=1,2
6936                       ind=ind+1
6937                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6938                     enddo
6939                   enddo
6940                 enddo
6941               enddo
6942               exit
6943             endif
6944           enddo
6945         endif
6946       enddo
6947       return
6948       end
6949 c------------------------------------------------------------------------------
6950       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6951       implicit real*8 (a-h,o-z)
6952       include 'DIMENSIONS'
6953       include 'COMMON.IOUNITS'
6954       include 'COMMON.DERIV'
6955       include 'COMMON.INTERACT'
6956       include 'COMMON.CONTACTS'
6957       double precision gx(3),gx1(3)
6958       logical lprn
6959       lprn=.false.
6960       eij=facont_hb(jj,i)
6961       ekl=facont_hb(kk,k)
6962       ees0pij=ees0p(jj,i)
6963       ees0pkl=ees0p(kk,k)
6964       ees0mij=ees0m(jj,i)
6965       ees0mkl=ees0m(kk,k)
6966       ekont=eij*ekl
6967       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6968 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6969 C Following 4 lines for diagnostics.
6970 cd    ees0pkl=0.0D0
6971 cd    ees0pij=1.0D0
6972 cd    ees0mkl=0.0D0
6973 cd    ees0mij=1.0D0
6974 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6975 c     & 'Contacts ',i,j,
6976 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6977 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6978 c     & 'gradcorr_long'
6979 C Calculate the multi-body contribution to energy.
6980 c      ecorr=ecorr+ekont*ees
6981 C Calculate multi-body contributions to the gradient.
6982       coeffpees0pij=coeffp*ees0pij
6983       coeffmees0mij=coeffm*ees0mij
6984       coeffpees0pkl=coeffp*ees0pkl
6985       coeffmees0mkl=coeffm*ees0mkl
6986       do ll=1,3
6987 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6988         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6989      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6990      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6991         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6992      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6993      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6994 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6995         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6996      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6997      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6998         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6999      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7000      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7001         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7002      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7003      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7004         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7005         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7006         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7007      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7008      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7009         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7010         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7011 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7012       enddo
7013 c      write (iout,*)
7014 cgrad      do m=i+1,j-1
7015 cgrad        do ll=1,3
7016 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7017 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7018 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7019 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7020 cgrad        enddo
7021 cgrad      enddo
7022 cgrad      do m=k+1,l-1
7023 cgrad        do ll=1,3
7024 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7025 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7026 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7027 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7028 cgrad        enddo
7029 cgrad      enddo
7030 c      write (iout,*) "ehbcorr",ekont*ees
7031       ehbcorr=ekont*ees
7032       return
7033       end
7034 #ifdef MOMENT
7035 C---------------------------------------------------------------------------
7036       subroutine dipole(i,j,jj)
7037       implicit real*8 (a-h,o-z)
7038       include 'DIMENSIONS'
7039       include 'COMMON.IOUNITS'
7040       include 'COMMON.CHAIN'
7041       include 'COMMON.FFIELD'
7042       include 'COMMON.DERIV'
7043       include 'COMMON.INTERACT'
7044       include 'COMMON.CONTACTS'
7045       include 'COMMON.TORSION'
7046       include 'COMMON.VAR'
7047       include 'COMMON.GEO'
7048       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7049      &  auxmat(2,2)
7050       iti1 = itortyp(itype(i+1))
7051       if (j.lt.nres-1) then
7052         itj1 = itortyp(itype(j+1))
7053       else
7054         itj1=ntortyp+1
7055       endif
7056       do iii=1,2
7057         dipi(iii,1)=Ub2(iii,i)
7058         dipderi(iii)=Ub2der(iii,i)
7059         dipi(iii,2)=b1(iii,iti1)
7060         dipj(iii,1)=Ub2(iii,j)
7061         dipderj(iii)=Ub2der(iii,j)
7062         dipj(iii,2)=b1(iii,itj1)
7063       enddo
7064       kkk=0
7065       do iii=1,2
7066         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7067         do jjj=1,2
7068           kkk=kkk+1
7069           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7070         enddo
7071       enddo
7072       do kkk=1,5
7073         do lll=1,3
7074           mmm=0
7075           do iii=1,2
7076             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7077      &        auxvec(1))
7078             do jjj=1,2
7079               mmm=mmm+1
7080               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7081             enddo
7082           enddo
7083         enddo
7084       enddo
7085       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7086       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7087       do iii=1,2
7088         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7089       enddo
7090       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7091       do iii=1,2
7092         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7093       enddo
7094       return
7095       end
7096 #endif
7097 C---------------------------------------------------------------------------
7098       subroutine calc_eello(i,j,k,l,jj,kk)
7099 C
7100 C This subroutine computes matrices and vectors needed to calculate
7101 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7102 C
7103       implicit real*8 (a-h,o-z)
7104       include 'DIMENSIONS'
7105       include 'COMMON.IOUNITS'
7106       include 'COMMON.CHAIN'
7107       include 'COMMON.DERIV'
7108       include 'COMMON.INTERACT'
7109       include 'COMMON.CONTACTS'
7110       include 'COMMON.TORSION'
7111       include 'COMMON.VAR'
7112       include 'COMMON.GEO'
7113       include 'COMMON.FFIELD'
7114       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7115      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7116       logical lprn
7117       common /kutas/ lprn
7118 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7119 cd     & ' jj=',jj,' kk=',kk
7120 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7121 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7122 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7123       do iii=1,2
7124         do jjj=1,2
7125           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7126           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7127         enddo
7128       enddo
7129       call transpose2(aa1(1,1),aa1t(1,1))
7130       call transpose2(aa2(1,1),aa2t(1,1))
7131       do kkk=1,5
7132         do lll=1,3
7133           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7134      &      aa1tder(1,1,lll,kkk))
7135           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7136      &      aa2tder(1,1,lll,kkk))
7137         enddo
7138       enddo
7139       if (l.eq.j+1) then
7140 C parallel orientation of the two CA-CA-CA frames.
7141         if (i.gt.1) then
7142           iti=itortyp(itype(i))
7143         else
7144           iti=ntortyp+1
7145         endif
7146         itk1=itortyp(itype(k+1))
7147         itj=itortyp(itype(j))
7148         if (l.lt.nres-1) then
7149           itl1=itortyp(itype(l+1))
7150         else
7151           itl1=ntortyp+1
7152         endif
7153 C A1 kernel(j+1) A2T
7154 cd        do iii=1,2
7155 cd          write (iout,'(3f10.5,5x,3f10.5)')
7156 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7157 cd        enddo
7158         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7159      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7160      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7161 C Following matrices are needed only for 6-th order cumulants
7162         IF (wcorr6.gt.0.0d0) THEN
7163         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7164      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7165      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7166         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7167      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7168      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7169      &   ADtEAderx(1,1,1,1,1,1))
7170         lprn=.false.
7171         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7172      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7173      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7174      &   ADtEA1derx(1,1,1,1,1,1))
7175         ENDIF
7176 C End 6-th order cumulants
7177 cd        lprn=.false.
7178 cd        if (lprn) then
7179 cd        write (2,*) 'In calc_eello6'
7180 cd        do iii=1,2
7181 cd          write (2,*) 'iii=',iii
7182 cd          do kkk=1,5
7183 cd            write (2,*) 'kkk=',kkk
7184 cd            do jjj=1,2
7185 cd              write (2,'(3(2f10.5),5x)')
7186 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7187 cd            enddo
7188 cd          enddo
7189 cd        enddo
7190 cd        endif
7191         call transpose2(EUgder(1,1,k),auxmat(1,1))
7192         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7193         call transpose2(EUg(1,1,k),auxmat(1,1))
7194         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7195         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7196         do iii=1,2
7197           do kkk=1,5
7198             do lll=1,3
7199               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7200      &          EAEAderx(1,1,lll,kkk,iii,1))
7201             enddo
7202           enddo
7203         enddo
7204 C A1T kernel(i+1) A2
7205         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7206      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7207      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7208 C Following matrices are needed only for 6-th order cumulants
7209         IF (wcorr6.gt.0.0d0) THEN
7210         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7211      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7212      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7213         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7214      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7215      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7216      &   ADtEAderx(1,1,1,1,1,2))
7217         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7218      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7219      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7220      &   ADtEA1derx(1,1,1,1,1,2))
7221         ENDIF
7222 C End 6-th order cumulants
7223         call transpose2(EUgder(1,1,l),auxmat(1,1))
7224         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7225         call transpose2(EUg(1,1,l),auxmat(1,1))
7226         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7227         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7228         do iii=1,2
7229           do kkk=1,5
7230             do lll=1,3
7231               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7232      &          EAEAderx(1,1,lll,kkk,iii,2))
7233             enddo
7234           enddo
7235         enddo
7236 C AEAb1 and AEAb2
7237 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7238 C They are needed only when the fifth- or the sixth-order cumulants are
7239 C indluded.
7240         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7241         call transpose2(AEA(1,1,1),auxmat(1,1))
7242         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7243         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7244         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7245         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7246         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7247         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7248         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7249         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7250         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7251         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7252         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7253         call transpose2(AEA(1,1,2),auxmat(1,1))
7254         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7255         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7256         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7257         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7258         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7259         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7260         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7261         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7262         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7263         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7264         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7265 C Calculate the Cartesian derivatives of the vectors.
7266         do iii=1,2
7267           do kkk=1,5
7268             do lll=1,3
7269               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7270               call matvec2(auxmat(1,1),b1(1,iti),
7271      &          AEAb1derx(1,lll,kkk,iii,1,1))
7272               call matvec2(auxmat(1,1),Ub2(1,i),
7273      &          AEAb2derx(1,lll,kkk,iii,1,1))
7274               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7275      &          AEAb1derx(1,lll,kkk,iii,2,1))
7276               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7277      &          AEAb2derx(1,lll,kkk,iii,2,1))
7278               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7279               call matvec2(auxmat(1,1),b1(1,itj),
7280      &          AEAb1derx(1,lll,kkk,iii,1,2))
7281               call matvec2(auxmat(1,1),Ub2(1,j),
7282      &          AEAb2derx(1,lll,kkk,iii,1,2))
7283               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7284      &          AEAb1derx(1,lll,kkk,iii,2,2))
7285               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7286      &          AEAb2derx(1,lll,kkk,iii,2,2))
7287             enddo
7288           enddo
7289         enddo
7290         ENDIF
7291 C End vectors
7292       else
7293 C Antiparallel orientation of the two CA-CA-CA frames.
7294         if (i.gt.1) then
7295           iti=itortyp(itype(i))
7296         else
7297           iti=ntortyp+1
7298         endif
7299         itk1=itortyp(itype(k+1))
7300         itl=itortyp(itype(l))
7301         itj=itortyp(itype(j))
7302         if (j.lt.nres-1) then
7303           itj1=itortyp(itype(j+1))
7304         else
7305           itj1=ntortyp+1
7306         endif
7307 C A2 kernel(j-1)T A1T
7308         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7309      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7310      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7311 C Following matrices are needed only for 6-th order cumulants
7312         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7313      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7314         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7315      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7316      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7317         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7318      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7319      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7320      &   ADtEAderx(1,1,1,1,1,1))
7321         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7322      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7323      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7324      &   ADtEA1derx(1,1,1,1,1,1))
7325         ENDIF
7326 C End 6-th order cumulants
7327         call transpose2(EUgder(1,1,k),auxmat(1,1))
7328         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7329         call transpose2(EUg(1,1,k),auxmat(1,1))
7330         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7331         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7332         do iii=1,2
7333           do kkk=1,5
7334             do lll=1,3
7335               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7336      &          EAEAderx(1,1,lll,kkk,iii,1))
7337             enddo
7338           enddo
7339         enddo
7340 C A2T kernel(i+1)T A1
7341         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7342      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7343      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7344 C Following matrices are needed only for 6-th order cumulants
7345         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7346      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7347         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7348      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7349      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7350         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7351      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7352      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7353      &   ADtEAderx(1,1,1,1,1,2))
7354         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7355      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7356      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7357      &   ADtEA1derx(1,1,1,1,1,2))
7358         ENDIF
7359 C End 6-th order cumulants
7360         call transpose2(EUgder(1,1,j),auxmat(1,1))
7361         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7362         call transpose2(EUg(1,1,j),auxmat(1,1))
7363         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7364         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7365         do iii=1,2
7366           do kkk=1,5
7367             do lll=1,3
7368               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7369      &          EAEAderx(1,1,lll,kkk,iii,2))
7370             enddo
7371           enddo
7372         enddo
7373 C AEAb1 and AEAb2
7374 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7375 C They are needed only when the fifth- or the sixth-order cumulants are
7376 C indluded.
7377         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7378      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7379         call transpose2(AEA(1,1,1),auxmat(1,1))
7380         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7381         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7382         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7383         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7384         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7385         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7386         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7387         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7388         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7389         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7390         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7391         call transpose2(AEA(1,1,2),auxmat(1,1))
7392         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7393         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7394         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7395         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7396         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7397         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7398         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7399         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7400         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7401         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7402         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7403 C Calculate the Cartesian derivatives of the vectors.
7404         do iii=1,2
7405           do kkk=1,5
7406             do lll=1,3
7407               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7408               call matvec2(auxmat(1,1),b1(1,iti),
7409      &          AEAb1derx(1,lll,kkk,iii,1,1))
7410               call matvec2(auxmat(1,1),Ub2(1,i),
7411      &          AEAb2derx(1,lll,kkk,iii,1,1))
7412               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7413      &          AEAb1derx(1,lll,kkk,iii,2,1))
7414               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7415      &          AEAb2derx(1,lll,kkk,iii,2,1))
7416               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7417               call matvec2(auxmat(1,1),b1(1,itl),
7418      &          AEAb1derx(1,lll,kkk,iii,1,2))
7419               call matvec2(auxmat(1,1),Ub2(1,l),
7420      &          AEAb2derx(1,lll,kkk,iii,1,2))
7421               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7422      &          AEAb1derx(1,lll,kkk,iii,2,2))
7423               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7424      &          AEAb2derx(1,lll,kkk,iii,2,2))
7425             enddo
7426           enddo
7427         enddo
7428         ENDIF
7429 C End vectors
7430       endif
7431       return
7432       end
7433 C---------------------------------------------------------------------------
7434       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7435      &  KK,KKderg,AKA,AKAderg,AKAderx)
7436       implicit none
7437       integer nderg
7438       logical transp
7439       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7440      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7441      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7442       integer iii,kkk,lll
7443       integer jjj,mmm
7444       logical lprn
7445       common /kutas/ lprn
7446       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7447       do iii=1,nderg
7448         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7449      &    AKAderg(1,1,iii))
7450       enddo
7451 cd      if (lprn) write (2,*) 'In kernel'
7452       do kkk=1,5
7453 cd        if (lprn) write (2,*) 'kkk=',kkk
7454         do lll=1,3
7455           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7456      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7457 cd          if (lprn) then
7458 cd            write (2,*) 'lll=',lll
7459 cd            write (2,*) 'iii=1'
7460 cd            do jjj=1,2
7461 cd              write (2,'(3(2f10.5),5x)')
7462 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7463 cd            enddo
7464 cd          endif
7465           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7466      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7467 cd          if (lprn) then
7468 cd            write (2,*) 'lll=',lll
7469 cd            write (2,*) 'iii=2'
7470 cd            do jjj=1,2
7471 cd              write (2,'(3(2f10.5),5x)')
7472 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7473 cd            enddo
7474 cd          endif
7475         enddo
7476       enddo
7477       return
7478       end
7479 C---------------------------------------------------------------------------
7480       double precision function eello4(i,j,k,l,jj,kk)
7481       implicit real*8 (a-h,o-z)
7482       include 'DIMENSIONS'
7483       include 'COMMON.IOUNITS'
7484       include 'COMMON.CHAIN'
7485       include 'COMMON.DERIV'
7486       include 'COMMON.INTERACT'
7487       include 'COMMON.CONTACTS'
7488       include 'COMMON.TORSION'
7489       include 'COMMON.VAR'
7490       include 'COMMON.GEO'
7491       double precision pizda(2,2),ggg1(3),ggg2(3)
7492 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7493 cd        eello4=0.0d0
7494 cd        return
7495 cd      endif
7496 cd      print *,'eello4:',i,j,k,l,jj,kk
7497 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7498 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7499 cold      eij=facont_hb(jj,i)
7500 cold      ekl=facont_hb(kk,k)
7501 cold      ekont=eij*ekl
7502       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7503 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7504       gcorr_loc(k-1)=gcorr_loc(k-1)
7505      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7506       if (l.eq.j+1) then
7507         gcorr_loc(l-1)=gcorr_loc(l-1)
7508      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7509       else
7510         gcorr_loc(j-1)=gcorr_loc(j-1)
7511      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7512       endif
7513       do iii=1,2
7514         do kkk=1,5
7515           do lll=1,3
7516             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7517      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7518 cd            derx(lll,kkk,iii)=0.0d0
7519           enddo
7520         enddo
7521       enddo
7522 cd      gcorr_loc(l-1)=0.0d0
7523 cd      gcorr_loc(j-1)=0.0d0
7524 cd      gcorr_loc(k-1)=0.0d0
7525 cd      eel4=1.0d0
7526 cd      write (iout,*)'Contacts have occurred for peptide groups',
7527 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7528 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7529       if (j.lt.nres-1) then
7530         j1=j+1
7531         j2=j-1
7532       else
7533         j1=j-1
7534         j2=j-2
7535       endif
7536       if (l.lt.nres-1) then
7537         l1=l+1
7538         l2=l-1
7539       else
7540         l1=l-1
7541         l2=l-2
7542       endif
7543       do ll=1,3
7544 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7545 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7546         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7547         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7548 cgrad        ghalf=0.5d0*ggg1(ll)
7549         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7550         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7551         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7552         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7553         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7554         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7555 cgrad        ghalf=0.5d0*ggg2(ll)
7556         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7557         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7558         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7559         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7560         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7561         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7562       enddo
7563 cgrad      do m=i+1,j-1
7564 cgrad        do ll=1,3
7565 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7566 cgrad        enddo
7567 cgrad      enddo
7568 cgrad      do m=k+1,l-1
7569 cgrad        do ll=1,3
7570 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7571 cgrad        enddo
7572 cgrad      enddo
7573 cgrad      do m=i+2,j2
7574 cgrad        do ll=1,3
7575 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7576 cgrad        enddo
7577 cgrad      enddo
7578 cgrad      do m=k+2,l2
7579 cgrad        do ll=1,3
7580 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7581 cgrad        enddo
7582 cgrad      enddo
7583 cd      do iii=1,nres-3
7584 cd        write (2,*) iii,gcorr_loc(iii)
7585 cd      enddo
7586       eello4=ekont*eel4
7587 cd      write (2,*) 'ekont',ekont
7588 cd      write (iout,*) 'eello4',ekont*eel4
7589       return
7590       end
7591 C---------------------------------------------------------------------------
7592       double precision function eello5(i,j,k,l,jj,kk)
7593       implicit real*8 (a-h,o-z)
7594       include 'DIMENSIONS'
7595       include 'COMMON.IOUNITS'
7596       include 'COMMON.CHAIN'
7597       include 'COMMON.DERIV'
7598       include 'COMMON.INTERACT'
7599       include 'COMMON.CONTACTS'
7600       include 'COMMON.TORSION'
7601       include 'COMMON.VAR'
7602       include 'COMMON.GEO'
7603       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7604       double precision ggg1(3),ggg2(3)
7605 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7606 C                                                                              C
7607 C                            Parallel chains                                   C
7608 C                                                                              C
7609 C          o             o                   o             o                   C
7610 C         /l\           / \             \   / \           / \   /              C
7611 C        /   \         /   \             \ /   \         /   \ /               C
7612 C       j| o |l1       | o |              o| o |         | o |o                C
7613 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7614 C      \i/   \         /   \ /             /   \         /   \                 C
7615 C       o    k1             o                                                  C
7616 C         (I)          (II)                (III)          (IV)                 C
7617 C                                                                              C
7618 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7619 C                                                                              C
7620 C                            Antiparallel chains                               C
7621 C                                                                              C
7622 C          o             o                   o             o                   C
7623 C         /j\           / \             \   / \           / \   /              C
7624 C        /   \         /   \             \ /   \         /   \ /               C
7625 C      j1| o |l        | o |              o| o |         | o |o                C
7626 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7627 C      \i/   \         /   \ /             /   \         /   \                 C
7628 C       o     k1            o                                                  C
7629 C         (I)          (II)                (III)          (IV)                 C
7630 C                                                                              C
7631 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7632 C                                                                              C
7633 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7634 C                                                                              C
7635 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7636 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7637 cd        eello5=0.0d0
7638 cd        return
7639 cd      endif
7640 cd      write (iout,*)
7641 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7642 cd     &   ' and',k,l
7643       itk=itortyp(itype(k))
7644       itl=itortyp(itype(l))
7645       itj=itortyp(itype(j))
7646       eello5_1=0.0d0
7647       eello5_2=0.0d0
7648       eello5_3=0.0d0
7649       eello5_4=0.0d0
7650 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7651 cd     &   eel5_3_num,eel5_4_num)
7652       do iii=1,2
7653         do kkk=1,5
7654           do lll=1,3
7655             derx(lll,kkk,iii)=0.0d0
7656           enddo
7657         enddo
7658       enddo
7659 cd      eij=facont_hb(jj,i)
7660 cd      ekl=facont_hb(kk,k)
7661 cd      ekont=eij*ekl
7662 cd      write (iout,*)'Contacts have occurred for peptide groups',
7663 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7664 cd      goto 1111
7665 C Contribution from the graph I.
7666 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7667 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7668       call transpose2(EUg(1,1,k),auxmat(1,1))
7669       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7670       vv(1)=pizda(1,1)-pizda(2,2)
7671       vv(2)=pizda(1,2)+pizda(2,1)
7672       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7673      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7674 C Explicit gradient in virtual-dihedral angles.
7675       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7676      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7677      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7678       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7679       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7680       vv(1)=pizda(1,1)-pizda(2,2)
7681       vv(2)=pizda(1,2)+pizda(2,1)
7682       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7683      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7684      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7685       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7686       vv(1)=pizda(1,1)-pizda(2,2)
7687       vv(2)=pizda(1,2)+pizda(2,1)
7688       if (l.eq.j+1) then
7689         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7690      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7691      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7692       else
7693         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7694      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7695      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7696       endif
7697 C Cartesian gradient
7698       do iii=1,2
7699         do kkk=1,5
7700           do lll=1,3
7701             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7702      &        pizda(1,1))
7703             vv(1)=pizda(1,1)-pizda(2,2)
7704             vv(2)=pizda(1,2)+pizda(2,1)
7705             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7706      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7707      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7708           enddo
7709         enddo
7710       enddo
7711 c      goto 1112
7712 c1111  continue
7713 C Contribution from graph II
7714       call transpose2(EE(1,1,itk),auxmat(1,1))
7715       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7716       vv(1)=pizda(1,1)+pizda(2,2)
7717       vv(2)=pizda(2,1)-pizda(1,2)
7718       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7719      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7720 C Explicit gradient in virtual-dihedral angles.
7721       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7722      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7723       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7724       vv(1)=pizda(1,1)+pizda(2,2)
7725       vv(2)=pizda(2,1)-pizda(1,2)
7726       if (l.eq.j+1) then
7727         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7728      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7729      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7730       else
7731         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7732      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7733      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7734       endif
7735 C Cartesian gradient
7736       do iii=1,2
7737         do kkk=1,5
7738           do lll=1,3
7739             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7740      &        pizda(1,1))
7741             vv(1)=pizda(1,1)+pizda(2,2)
7742             vv(2)=pizda(2,1)-pizda(1,2)
7743             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7744      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7745      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7746           enddo
7747         enddo
7748       enddo
7749 cd      goto 1112
7750 cd1111  continue
7751       if (l.eq.j+1) then
7752 cd        goto 1110
7753 C Parallel orientation
7754 C Contribution from graph III
7755         call transpose2(EUg(1,1,l),auxmat(1,1))
7756         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7757         vv(1)=pizda(1,1)-pizda(2,2)
7758         vv(2)=pizda(1,2)+pizda(2,1)
7759         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7760      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7761 C Explicit gradient in virtual-dihedral angles.
7762         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7763      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7764      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7765         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7766         vv(1)=pizda(1,1)-pizda(2,2)
7767         vv(2)=pizda(1,2)+pizda(2,1)
7768         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7769      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7770      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7771         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7772         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7773         vv(1)=pizda(1,1)-pizda(2,2)
7774         vv(2)=pizda(1,2)+pizda(2,1)
7775         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7776      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7777      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7778 C Cartesian gradient
7779         do iii=1,2
7780           do kkk=1,5
7781             do lll=1,3
7782               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7783      &          pizda(1,1))
7784               vv(1)=pizda(1,1)-pizda(2,2)
7785               vv(2)=pizda(1,2)+pizda(2,1)
7786               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7787      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7788      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7789             enddo
7790           enddo
7791         enddo
7792 cd        goto 1112
7793 C Contribution from graph IV
7794 cd1110    continue
7795         call transpose2(EE(1,1,itl),auxmat(1,1))
7796         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7797         vv(1)=pizda(1,1)+pizda(2,2)
7798         vv(2)=pizda(2,1)-pizda(1,2)
7799         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7800      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7801 C Explicit gradient in virtual-dihedral angles.
7802         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7803      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7804         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7805         vv(1)=pizda(1,1)+pizda(2,2)
7806         vv(2)=pizda(2,1)-pizda(1,2)
7807         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7808      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7809      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7810 C Cartesian gradient
7811         do iii=1,2
7812           do kkk=1,5
7813             do lll=1,3
7814               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7815      &          pizda(1,1))
7816               vv(1)=pizda(1,1)+pizda(2,2)
7817               vv(2)=pizda(2,1)-pizda(1,2)
7818               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7819      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7820      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7821             enddo
7822           enddo
7823         enddo
7824       else
7825 C Antiparallel orientation
7826 C Contribution from graph III
7827 c        goto 1110
7828         call transpose2(EUg(1,1,j),auxmat(1,1))
7829         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7830         vv(1)=pizda(1,1)-pizda(2,2)
7831         vv(2)=pizda(1,2)+pizda(2,1)
7832         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7833      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7834 C Explicit gradient in virtual-dihedral angles.
7835         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7836      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7837      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7838         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7839         vv(1)=pizda(1,1)-pizda(2,2)
7840         vv(2)=pizda(1,2)+pizda(2,1)
7841         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7842      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7843      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7844         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7845         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7846         vv(1)=pizda(1,1)-pizda(2,2)
7847         vv(2)=pizda(1,2)+pizda(2,1)
7848         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7849      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7850      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7851 C Cartesian gradient
7852         do iii=1,2
7853           do kkk=1,5
7854             do lll=1,3
7855               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7856      &          pizda(1,1))
7857               vv(1)=pizda(1,1)-pizda(2,2)
7858               vv(2)=pizda(1,2)+pizda(2,1)
7859               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7860      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7861      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7862             enddo
7863           enddo
7864         enddo
7865 cd        goto 1112
7866 C Contribution from graph IV
7867 1110    continue
7868         call transpose2(EE(1,1,itj),auxmat(1,1))
7869         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7870         vv(1)=pizda(1,1)+pizda(2,2)
7871         vv(2)=pizda(2,1)-pizda(1,2)
7872         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7873      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7874 C Explicit gradient in virtual-dihedral angles.
7875         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7876      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7877         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7878         vv(1)=pizda(1,1)+pizda(2,2)
7879         vv(2)=pizda(2,1)-pizda(1,2)
7880         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7881      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7882      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7883 C Cartesian gradient
7884         do iii=1,2
7885           do kkk=1,5
7886             do lll=1,3
7887               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7888      &          pizda(1,1))
7889               vv(1)=pizda(1,1)+pizda(2,2)
7890               vv(2)=pizda(2,1)-pizda(1,2)
7891               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7892      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7893      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7894             enddo
7895           enddo
7896         enddo
7897       endif
7898 1112  continue
7899       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7900 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7901 cd        write (2,*) 'ijkl',i,j,k,l
7902 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7903 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7904 cd      endif
7905 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7906 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7907 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7908 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7909       if (j.lt.nres-1) then
7910         j1=j+1
7911         j2=j-1
7912       else
7913         j1=j-1
7914         j2=j-2
7915       endif
7916       if (l.lt.nres-1) then
7917         l1=l+1
7918         l2=l-1
7919       else
7920         l1=l-1
7921         l2=l-2
7922       endif
7923 cd      eij=1.0d0
7924 cd      ekl=1.0d0
7925 cd      ekont=1.0d0
7926 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7927 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7928 C        summed up outside the subrouine as for the other subroutines
7929 C        handling long-range interactions. The old code is commented out
7930 C        with "cgrad" to keep track of changes.
7931       do ll=1,3
7932 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7933 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7934         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7935         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7936 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7937 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7938 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7939 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7940 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7941 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7942 c     &   gradcorr5ij,
7943 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7944 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7945 cgrad        ghalf=0.5d0*ggg1(ll)
7946 cd        ghalf=0.0d0
7947         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7948         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7949         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7950         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7951         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7952         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7953 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7954 cgrad        ghalf=0.5d0*ggg2(ll)
7955 cd        ghalf=0.0d0
7956         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7957         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7958         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7959         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7960         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7961         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7962       enddo
7963 cd      goto 1112
7964 cgrad      do m=i+1,j-1
7965 cgrad        do ll=1,3
7966 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7967 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7968 cgrad        enddo
7969 cgrad      enddo
7970 cgrad      do m=k+1,l-1
7971 cgrad        do ll=1,3
7972 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7973 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7974 cgrad        enddo
7975 cgrad      enddo
7976 c1112  continue
7977 cgrad      do m=i+2,j2
7978 cgrad        do ll=1,3
7979 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7980 cgrad        enddo
7981 cgrad      enddo
7982 cgrad      do m=k+2,l2
7983 cgrad        do ll=1,3
7984 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7985 cgrad        enddo
7986 cgrad      enddo
7987 cd      do iii=1,nres-3
7988 cd        write (2,*) iii,g_corr5_loc(iii)
7989 cd      enddo
7990       eello5=ekont*eel5
7991 cd      write (2,*) 'ekont',ekont
7992 cd      write (iout,*) 'eello5',ekont*eel5
7993       return
7994       end
7995 c--------------------------------------------------------------------------
7996       double precision function eello6(i,j,k,l,jj,kk)
7997       implicit real*8 (a-h,o-z)
7998       include 'DIMENSIONS'
7999       include 'COMMON.IOUNITS'
8000       include 'COMMON.CHAIN'
8001       include 'COMMON.DERIV'
8002       include 'COMMON.INTERACT'
8003       include 'COMMON.CONTACTS'
8004       include 'COMMON.TORSION'
8005       include 'COMMON.VAR'
8006       include 'COMMON.GEO'
8007       include 'COMMON.FFIELD'
8008       double precision ggg1(3),ggg2(3)
8009 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8010 cd        eello6=0.0d0
8011 cd        return
8012 cd      endif
8013 cd      write (iout,*)
8014 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8015 cd     &   ' and',k,l
8016       eello6_1=0.0d0
8017       eello6_2=0.0d0
8018       eello6_3=0.0d0
8019       eello6_4=0.0d0
8020       eello6_5=0.0d0
8021       eello6_6=0.0d0
8022 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8023 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8024       do iii=1,2
8025         do kkk=1,5
8026           do lll=1,3
8027             derx(lll,kkk,iii)=0.0d0
8028           enddo
8029         enddo
8030       enddo
8031 cd      eij=facont_hb(jj,i)
8032 cd      ekl=facont_hb(kk,k)
8033 cd      ekont=eij*ekl
8034 cd      eij=1.0d0
8035 cd      ekl=1.0d0
8036 cd      ekont=1.0d0
8037       if (l.eq.j+1) then
8038         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8039         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8040         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8041         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8042         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8043         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8044       else
8045         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8046         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8047         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8048         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8049         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8050           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8051         else
8052           eello6_5=0.0d0
8053         endif
8054         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8055       endif
8056 C If turn contributions are considered, they will be handled separately.
8057       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8058 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8059 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8060 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8061 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8062 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8063 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8064 cd      goto 1112
8065       if (j.lt.nres-1) then
8066         j1=j+1
8067         j2=j-1
8068       else
8069         j1=j-1
8070         j2=j-2
8071       endif
8072       if (l.lt.nres-1) then
8073         l1=l+1
8074         l2=l-1
8075       else
8076         l1=l-1
8077         l2=l-2
8078       endif
8079       do ll=1,3
8080 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8081 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8082 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8083 cgrad        ghalf=0.5d0*ggg1(ll)
8084 cd        ghalf=0.0d0
8085         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8086         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8087         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8088         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8089         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8090         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8091         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8092         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8093 cgrad        ghalf=0.5d0*ggg2(ll)
8094 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8095 cd        ghalf=0.0d0
8096         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8097         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8098         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8099         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8100         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8101         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8102       enddo
8103 cd      goto 1112
8104 cgrad      do m=i+1,j-1
8105 cgrad        do ll=1,3
8106 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8107 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8108 cgrad        enddo
8109 cgrad      enddo
8110 cgrad      do m=k+1,l-1
8111 cgrad        do ll=1,3
8112 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8113 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8114 cgrad        enddo
8115 cgrad      enddo
8116 cgrad1112  continue
8117 cgrad      do m=i+2,j2
8118 cgrad        do ll=1,3
8119 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8120 cgrad        enddo
8121 cgrad      enddo
8122 cgrad      do m=k+2,l2
8123 cgrad        do ll=1,3
8124 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8125 cgrad        enddo
8126 cgrad      enddo
8127 cd      do iii=1,nres-3
8128 cd        write (2,*) iii,g_corr6_loc(iii)
8129 cd      enddo
8130       eello6=ekont*eel6
8131 cd      write (2,*) 'ekont',ekont
8132 cd      write (iout,*) 'eello6',ekont*eel6
8133       return
8134       end
8135 c--------------------------------------------------------------------------
8136       double precision function eello6_graph1(i,j,k,l,imat,swap)
8137       implicit real*8 (a-h,o-z)
8138       include 'DIMENSIONS'
8139       include 'COMMON.IOUNITS'
8140       include 'COMMON.CHAIN'
8141       include 'COMMON.DERIV'
8142       include 'COMMON.INTERACT'
8143       include 'COMMON.CONTACTS'
8144       include 'COMMON.TORSION'
8145       include 'COMMON.VAR'
8146       include 'COMMON.GEO'
8147       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8148       logical swap
8149       logical lprn
8150       common /kutas/ lprn
8151 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8152 C
8153 C      Parallel       Antiparallel
8154 C
8155 C          o             o
8156 C         /l\           /j\
8157 C        /   \         /   \
8158 C       /| o |         | o |\
8159 C     \ j|/k\|  /   \  |/k\|l /
8160 C      \ /   \ /     \ /   \ /
8161 C       o     o       o     o
8162 C       i             i
8163 C
8164 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8165       itk=itortyp(itype(k))
8166       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8167       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8168       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8169       call transpose2(EUgC(1,1,k),auxmat(1,1))
8170       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8171       vv1(1)=pizda1(1,1)-pizda1(2,2)
8172       vv1(2)=pizda1(1,2)+pizda1(2,1)
8173       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8174       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8175       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8176       s5=scalar2(vv(1),Dtobr2(1,i))
8177 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8178       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8179       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8180      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8181      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8182      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8183      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8184      & +scalar2(vv(1),Dtobr2der(1,i)))
8185       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8186       vv1(1)=pizda1(1,1)-pizda1(2,2)
8187       vv1(2)=pizda1(1,2)+pizda1(2,1)
8188       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8189       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8190       if (l.eq.j+1) then
8191         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8192      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8193      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8194      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8195      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8196       else
8197         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8198      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8199      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8200      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8201      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8202       endif
8203       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8204       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8205       vv1(1)=pizda1(1,1)-pizda1(2,2)
8206       vv1(2)=pizda1(1,2)+pizda1(2,1)
8207       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8208      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8209      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8210      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8211       do iii=1,2
8212         if (swap) then
8213           ind=3-iii
8214         else
8215           ind=iii
8216         endif
8217         do kkk=1,5
8218           do lll=1,3
8219             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8220             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8221             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8222             call transpose2(EUgC(1,1,k),auxmat(1,1))
8223             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8224      &        pizda1(1,1))
8225             vv1(1)=pizda1(1,1)-pizda1(2,2)
8226             vv1(2)=pizda1(1,2)+pizda1(2,1)
8227             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8228             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8229      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8230             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8231      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8232             s5=scalar2(vv(1),Dtobr2(1,i))
8233             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8234           enddo
8235         enddo
8236       enddo
8237       return
8238       end
8239 c----------------------------------------------------------------------------
8240       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8241       implicit real*8 (a-h,o-z)
8242       include 'DIMENSIONS'
8243       include 'COMMON.IOUNITS'
8244       include 'COMMON.CHAIN'
8245       include 'COMMON.DERIV'
8246       include 'COMMON.INTERACT'
8247       include 'COMMON.CONTACTS'
8248       include 'COMMON.TORSION'
8249       include 'COMMON.VAR'
8250       include 'COMMON.GEO'
8251       logical swap
8252       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8253      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8254       logical lprn
8255       common /kutas/ lprn
8256 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8257 C                                                                              C
8258 C      Parallel       Antiparallel                                             C
8259 C                                                                              C
8260 C          o             o                                                     C
8261 C     \   /l\           /j\   /                                                C
8262 C      \ /   \         /   \ /                                                 C
8263 C       o| o |         | o |o                                                  C
8264 C     \ j|/k\|      \  |/k\|l                                                  C
8265 C      \ /   \       \ /   \                                                   C
8266 C       o             o                                                        C
8267 C       i             i                                                        C
8268 C                                                                              C
8269 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8270 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8271 C AL 7/4/01 s1 would occur in the sixth-order moment,
8272 C           but not in a cluster cumulant
8273 #ifdef MOMENT
8274       s1=dip(1,jj,i)*dip(1,kk,k)
8275 #endif
8276       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8277       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8278       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8279       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8280       call transpose2(EUg(1,1,k),auxmat(1,1))
8281       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8282       vv(1)=pizda(1,1)-pizda(2,2)
8283       vv(2)=pizda(1,2)+pizda(2,1)
8284       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8285 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8286 #ifdef MOMENT
8287       eello6_graph2=-(s1+s2+s3+s4)
8288 #else
8289       eello6_graph2=-(s2+s3+s4)
8290 #endif
8291 c      eello6_graph2=-s3
8292 C Derivatives in gamma(i-1)
8293       if (i.gt.1) then
8294 #ifdef MOMENT
8295         s1=dipderg(1,jj,i)*dip(1,kk,k)
8296 #endif
8297         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8298         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8299         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8300         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8301 #ifdef MOMENT
8302         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8303 #else
8304         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8305 #endif
8306 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8307       endif
8308 C Derivatives in gamma(k-1)
8309 #ifdef MOMENT
8310       s1=dip(1,jj,i)*dipderg(1,kk,k)
8311 #endif
8312       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8313       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8314       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8315       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8316       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8317       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8318       vv(1)=pizda(1,1)-pizda(2,2)
8319       vv(2)=pizda(1,2)+pizda(2,1)
8320       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8321 #ifdef MOMENT
8322       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8323 #else
8324       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8325 #endif
8326 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8327 C Derivatives in gamma(j-1) or gamma(l-1)
8328       if (j.gt.1) then
8329 #ifdef MOMENT
8330         s1=dipderg(3,jj,i)*dip(1,kk,k)
8331 #endif
8332         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8333         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8334         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8335         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8336         vv(1)=pizda(1,1)-pizda(2,2)
8337         vv(2)=pizda(1,2)+pizda(2,1)
8338         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8339 #ifdef MOMENT
8340         if (swap) then
8341           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8342         else
8343           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8344         endif
8345 #endif
8346         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8347 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8348       endif
8349 C Derivatives in gamma(l-1) or gamma(j-1)
8350       if (l.gt.1) then
8351 #ifdef MOMENT
8352         s1=dip(1,jj,i)*dipderg(3,kk,k)
8353 #endif
8354         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8355         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8356         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8357         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8358         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8359         vv(1)=pizda(1,1)-pizda(2,2)
8360         vv(2)=pizda(1,2)+pizda(2,1)
8361         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8362 #ifdef MOMENT
8363         if (swap) then
8364           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8365         else
8366           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8367         endif
8368 #endif
8369         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8370 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8371       endif
8372 C Cartesian derivatives.
8373       if (lprn) then
8374         write (2,*) 'In eello6_graph2'
8375         do iii=1,2
8376           write (2,*) 'iii=',iii
8377           do kkk=1,5
8378             write (2,*) 'kkk=',kkk
8379             do jjj=1,2
8380               write (2,'(3(2f10.5),5x)')
8381      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8382             enddo
8383           enddo
8384         enddo
8385       endif
8386       do iii=1,2
8387         do kkk=1,5
8388           do lll=1,3
8389 #ifdef MOMENT
8390             if (iii.eq.1) then
8391               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8392             else
8393               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8394             endif
8395 #endif
8396             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8397      &        auxvec(1))
8398             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8399             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8400      &        auxvec(1))
8401             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8402             call transpose2(EUg(1,1,k),auxmat(1,1))
8403             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8404      &        pizda(1,1))
8405             vv(1)=pizda(1,1)-pizda(2,2)
8406             vv(2)=pizda(1,2)+pizda(2,1)
8407             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8408 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8409 #ifdef MOMENT
8410             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8411 #else
8412             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8413 #endif
8414             if (swap) then
8415               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8416             else
8417               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8418             endif
8419           enddo
8420         enddo
8421       enddo
8422       return
8423       end
8424 c----------------------------------------------------------------------------
8425       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8426       implicit real*8 (a-h,o-z)
8427       include 'DIMENSIONS'
8428       include 'COMMON.IOUNITS'
8429       include 'COMMON.CHAIN'
8430       include 'COMMON.DERIV'
8431       include 'COMMON.INTERACT'
8432       include 'COMMON.CONTACTS'
8433       include 'COMMON.TORSION'
8434       include 'COMMON.VAR'
8435       include 'COMMON.GEO'
8436       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8437       logical swap
8438 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8439 C                                                                              C
8440 C      Parallel       Antiparallel                                             C
8441 C                                                                              C
8442 C          o             o                                                     C
8443 C         /l\   /   \   /j\                                                    C
8444 C        /   \ /     \ /   \                                                   C
8445 C       /| o |o       o| o |\                                                  C
8446 C       j|/k\|  /      |/k\|l /                                                C
8447 C        /   \ /       /   \ /                                                 C
8448 C       /     o       /     o                                                  C
8449 C       i             i                                                        C
8450 C                                                                              C
8451 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8452 C
8453 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8454 C           energy moment and not to the cluster cumulant.
8455       iti=itortyp(itype(i))
8456       if (j.lt.nres-1) then
8457         itj1=itortyp(itype(j+1))
8458       else
8459         itj1=ntortyp+1
8460       endif
8461       itk=itortyp(itype(k))
8462       itk1=itortyp(itype(k+1))
8463       if (l.lt.nres-1) then
8464         itl1=itortyp(itype(l+1))
8465       else
8466         itl1=ntortyp+1
8467       endif
8468 #ifdef MOMENT
8469       s1=dip(4,jj,i)*dip(4,kk,k)
8470 #endif
8471       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8472       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8473       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8474       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8475       call transpose2(EE(1,1,itk),auxmat(1,1))
8476       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8477       vv(1)=pizda(1,1)+pizda(2,2)
8478       vv(2)=pizda(2,1)-pizda(1,2)
8479       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8480 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8481 cd     & "sum",-(s2+s3+s4)
8482 #ifdef MOMENT
8483       eello6_graph3=-(s1+s2+s3+s4)
8484 #else
8485       eello6_graph3=-(s2+s3+s4)
8486 #endif
8487 c      eello6_graph3=-s4
8488 C Derivatives in gamma(k-1)
8489       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8490       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8491       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8492       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8493 C Derivatives in gamma(l-1)
8494       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8495       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8496       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8497       vv(1)=pizda(1,1)+pizda(2,2)
8498       vv(2)=pizda(2,1)-pizda(1,2)
8499       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8500       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8501 C Cartesian derivatives.
8502       do iii=1,2
8503         do kkk=1,5
8504           do lll=1,3
8505 #ifdef MOMENT
8506             if (iii.eq.1) then
8507               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8508             else
8509               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8510             endif
8511 #endif
8512             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8513      &        auxvec(1))
8514             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8515             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8516      &        auxvec(1))
8517             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8518             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8519      &        pizda(1,1))
8520             vv(1)=pizda(1,1)+pizda(2,2)
8521             vv(2)=pizda(2,1)-pizda(1,2)
8522             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8523 #ifdef MOMENT
8524             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8525 #else
8526             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8527 #endif
8528             if (swap) then
8529               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8530             else
8531               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8532             endif
8533 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8534           enddo
8535         enddo
8536       enddo
8537       return
8538       end
8539 c----------------------------------------------------------------------------
8540       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8541       implicit real*8 (a-h,o-z)
8542       include 'DIMENSIONS'
8543       include 'COMMON.IOUNITS'
8544       include 'COMMON.CHAIN'
8545       include 'COMMON.DERIV'
8546       include 'COMMON.INTERACT'
8547       include 'COMMON.CONTACTS'
8548       include 'COMMON.TORSION'
8549       include 'COMMON.VAR'
8550       include 'COMMON.GEO'
8551       include 'COMMON.FFIELD'
8552       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8553      & auxvec1(2),auxmat1(2,2)
8554       logical swap
8555 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8556 C                                                                              C
8557 C      Parallel       Antiparallel                                             C
8558 C                                                                              C
8559 C          o             o                                                     C
8560 C         /l\   /   \   /j\                                                    C
8561 C        /   \ /     \ /   \                                                   C
8562 C       /| o |o       o| o |\                                                  C
8563 C     \ j|/k\|      \  |/k\|l                                                  C
8564 C      \ /   \       \ /   \                                                   C
8565 C       o     \       o     \                                                  C
8566 C       i             i                                                        C
8567 C                                                                              C
8568 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8569 C
8570 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8571 C           energy moment and not to the cluster cumulant.
8572 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8573       iti=itortyp(itype(i))
8574       itj=itortyp(itype(j))
8575       if (j.lt.nres-1) then
8576         itj1=itortyp(itype(j+1))
8577       else
8578         itj1=ntortyp+1
8579       endif
8580       itk=itortyp(itype(k))
8581       if (k.lt.nres-1) then
8582         itk1=itortyp(itype(k+1))
8583       else
8584         itk1=ntortyp+1
8585       endif
8586       itl=itortyp(itype(l))
8587       if (l.lt.nres-1) then
8588         itl1=itortyp(itype(l+1))
8589       else
8590         itl1=ntortyp+1
8591       endif
8592 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8593 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8594 cd     & ' itl',itl,' itl1',itl1
8595 #ifdef MOMENT
8596       if (imat.eq.1) then
8597         s1=dip(3,jj,i)*dip(3,kk,k)
8598       else
8599         s1=dip(2,jj,j)*dip(2,kk,l)
8600       endif
8601 #endif
8602       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8603       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8604       if (j.eq.l+1) then
8605         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8606         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8607       else
8608         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8609         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8610       endif
8611       call transpose2(EUg(1,1,k),auxmat(1,1))
8612       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8613       vv(1)=pizda(1,1)-pizda(2,2)
8614       vv(2)=pizda(2,1)+pizda(1,2)
8615       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8616 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8617 #ifdef MOMENT
8618       eello6_graph4=-(s1+s2+s3+s4)
8619 #else
8620       eello6_graph4=-(s2+s3+s4)
8621 #endif
8622 C Derivatives in gamma(i-1)
8623       if (i.gt.1) then
8624 #ifdef MOMENT
8625         if (imat.eq.1) then
8626           s1=dipderg(2,jj,i)*dip(3,kk,k)
8627         else
8628           s1=dipderg(4,jj,j)*dip(2,kk,l)
8629         endif
8630 #endif
8631         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8632         if (j.eq.l+1) then
8633           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8634           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8635         else
8636           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8637           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8638         endif
8639         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8640         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8641 cd          write (2,*) 'turn6 derivatives'
8642 #ifdef MOMENT
8643           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8644 #else
8645           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8646 #endif
8647         else
8648 #ifdef MOMENT
8649           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8650 #else
8651           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8652 #endif
8653         endif
8654       endif
8655 C Derivatives in gamma(k-1)
8656 #ifdef MOMENT
8657       if (imat.eq.1) then
8658         s1=dip(3,jj,i)*dipderg(2,kk,k)
8659       else
8660         s1=dip(2,jj,j)*dipderg(4,kk,l)
8661       endif
8662 #endif
8663       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8664       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8665       if (j.eq.l+1) then
8666         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8667         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8668       else
8669         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8670         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8671       endif
8672       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8673       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8674       vv(1)=pizda(1,1)-pizda(2,2)
8675       vv(2)=pizda(2,1)+pizda(1,2)
8676       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8677       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8678 #ifdef MOMENT
8679         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8680 #else
8681         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8682 #endif
8683       else
8684 #ifdef MOMENT
8685         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8686 #else
8687         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8688 #endif
8689       endif
8690 C Derivatives in gamma(j-1) or gamma(l-1)
8691       if (l.eq.j+1 .and. l.gt.1) then
8692         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8693         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8694         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8695         vv(1)=pizda(1,1)-pizda(2,2)
8696         vv(2)=pizda(2,1)+pizda(1,2)
8697         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8698         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8699       else if (j.gt.1) then
8700         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8701         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8702         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8703         vv(1)=pizda(1,1)-pizda(2,2)
8704         vv(2)=pizda(2,1)+pizda(1,2)
8705         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8706         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8707           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8708         else
8709           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8710         endif
8711       endif
8712 C Cartesian derivatives.
8713       do iii=1,2
8714         do kkk=1,5
8715           do lll=1,3
8716 #ifdef MOMENT
8717             if (iii.eq.1) then
8718               if (imat.eq.1) then
8719                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8720               else
8721                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8722               endif
8723             else
8724               if (imat.eq.1) then
8725                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8726               else
8727                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8728               endif
8729             endif
8730 #endif
8731             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8732      &        auxvec(1))
8733             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8734             if (j.eq.l+1) then
8735               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8736      &          b1(1,itj1),auxvec(1))
8737               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8738             else
8739               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8740      &          b1(1,itl1),auxvec(1))
8741               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8742             endif
8743             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8744      &        pizda(1,1))
8745             vv(1)=pizda(1,1)-pizda(2,2)
8746             vv(2)=pizda(2,1)+pizda(1,2)
8747             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8748             if (swap) then
8749               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8750 #ifdef MOMENT
8751                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8752      &             -(s1+s2+s4)
8753 #else
8754                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8755      &             -(s2+s4)
8756 #endif
8757                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8758               else
8759 #ifdef MOMENT
8760                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8761 #else
8762                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8763 #endif
8764                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8765               endif
8766             else
8767 #ifdef MOMENT
8768               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8769 #else
8770               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8771 #endif
8772               if (l.eq.j+1) then
8773                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8774               else
8775                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8776               endif
8777             endif
8778           enddo
8779         enddo
8780       enddo
8781       return
8782       end
8783 c----------------------------------------------------------------------------
8784       double precision function eello_turn6(i,jj,kk)
8785       implicit real*8 (a-h,o-z)
8786       include 'DIMENSIONS'
8787       include 'COMMON.IOUNITS'
8788       include 'COMMON.CHAIN'
8789       include 'COMMON.DERIV'
8790       include 'COMMON.INTERACT'
8791       include 'COMMON.CONTACTS'
8792       include 'COMMON.TORSION'
8793       include 'COMMON.VAR'
8794       include 'COMMON.GEO'
8795       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8796      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8797      &  ggg1(3),ggg2(3)
8798       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8799      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8800 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8801 C           the respective energy moment and not to the cluster cumulant.
8802       s1=0.0d0
8803       s8=0.0d0
8804       s13=0.0d0
8805 c
8806       eello_turn6=0.0d0
8807       j=i+4
8808       k=i+1
8809       l=i+3
8810       iti=itortyp(itype(i))
8811       itk=itortyp(itype(k))
8812       itk1=itortyp(itype(k+1))
8813       itl=itortyp(itype(l))
8814       itj=itortyp(itype(j))
8815 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8816 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8817 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8818 cd        eello6=0.0d0
8819 cd        return
8820 cd      endif
8821 cd      write (iout,*)
8822 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8823 cd     &   ' and',k,l
8824 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8825       do iii=1,2
8826         do kkk=1,5
8827           do lll=1,3
8828             derx_turn(lll,kkk,iii)=0.0d0
8829           enddo
8830         enddo
8831       enddo
8832 cd      eij=1.0d0
8833 cd      ekl=1.0d0
8834 cd      ekont=1.0d0
8835       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8836 cd      eello6_5=0.0d0
8837 cd      write (2,*) 'eello6_5',eello6_5
8838 #ifdef MOMENT
8839       call transpose2(AEA(1,1,1),auxmat(1,1))
8840       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8841       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8842       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8843 #endif
8844       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8845       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8846       s2 = scalar2(b1(1,itk),vtemp1(1))
8847 #ifdef MOMENT
8848       call transpose2(AEA(1,1,2),atemp(1,1))
8849       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8850       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8851       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8852 #endif
8853       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8854       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8855       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8856 #ifdef MOMENT
8857       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8858       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8859       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8860       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8861       ss13 = scalar2(b1(1,itk),vtemp4(1))
8862       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8863 #endif
8864 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8865 c      s1=0.0d0
8866 c      s2=0.0d0
8867 c      s8=0.0d0
8868 c      s12=0.0d0
8869 c      s13=0.0d0
8870       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8871 C Derivatives in gamma(i+2)
8872       s1d =0.0d0
8873       s8d =0.0d0
8874 #ifdef MOMENT
8875       call transpose2(AEA(1,1,1),auxmatd(1,1))
8876       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8877       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8878       call transpose2(AEAderg(1,1,2),atempd(1,1))
8879       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8880       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8881 #endif
8882       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8883       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8884       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8885 c      s1d=0.0d0
8886 c      s2d=0.0d0
8887 c      s8d=0.0d0
8888 c      s12d=0.0d0
8889 c      s13d=0.0d0
8890       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8891 C Derivatives in gamma(i+3)
8892 #ifdef MOMENT
8893       call transpose2(AEA(1,1,1),auxmatd(1,1))
8894       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8895       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8896       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8897 #endif
8898       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8899       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8900       s2d = scalar2(b1(1,itk),vtemp1d(1))
8901 #ifdef MOMENT
8902       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8903       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8904 #endif
8905       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8906 #ifdef MOMENT
8907       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8908       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8909       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8910 #endif
8911 c      s1d=0.0d0
8912 c      s2d=0.0d0
8913 c      s8d=0.0d0
8914 c      s12d=0.0d0
8915 c      s13d=0.0d0
8916 #ifdef MOMENT
8917       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8918      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8919 #else
8920       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8921      &               -0.5d0*ekont*(s2d+s12d)
8922 #endif
8923 C Derivatives in gamma(i+4)
8924       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8925       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8926       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8927 #ifdef MOMENT
8928       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8929       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8930       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8931 #endif
8932 c      s1d=0.0d0
8933 c      s2d=0.0d0
8934 c      s8d=0.0d0
8935 C      s12d=0.0d0
8936 c      s13d=0.0d0
8937 #ifdef MOMENT
8938       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8939 #else
8940       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8941 #endif
8942 C Derivatives in gamma(i+5)
8943 #ifdef MOMENT
8944       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8945       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8946       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8947 #endif
8948       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8949       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8950       s2d = scalar2(b1(1,itk),vtemp1d(1))
8951 #ifdef MOMENT
8952       call transpose2(AEA(1,1,2),atempd(1,1))
8953       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8954       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8955 #endif
8956       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8957       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8958 #ifdef MOMENT
8959       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8960       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8961       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8962 #endif
8963 c      s1d=0.0d0
8964 c      s2d=0.0d0
8965 c      s8d=0.0d0
8966 c      s12d=0.0d0
8967 c      s13d=0.0d0
8968 #ifdef MOMENT
8969       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8970      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8971 #else
8972       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8973      &               -0.5d0*ekont*(s2d+s12d)
8974 #endif
8975 C Cartesian derivatives
8976       do iii=1,2
8977         do kkk=1,5
8978           do lll=1,3
8979 #ifdef MOMENT
8980             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8981             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8982             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8983 #endif
8984             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8985             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8986      &          vtemp1d(1))
8987             s2d = scalar2(b1(1,itk),vtemp1d(1))
8988 #ifdef MOMENT
8989             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8990             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8991             s8d = -(atempd(1,1)+atempd(2,2))*
8992      &           scalar2(cc(1,1,itl),vtemp2(1))
8993 #endif
8994             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8995      &           auxmatd(1,1))
8996             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8997             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8998 c      s1d=0.0d0
8999 c      s2d=0.0d0
9000 c      s8d=0.0d0
9001 c      s12d=0.0d0
9002 c      s13d=0.0d0
9003 #ifdef MOMENT
9004             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9005      &        - 0.5d0*(s1d+s2d)
9006 #else
9007             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9008      &        - 0.5d0*s2d
9009 #endif
9010 #ifdef MOMENT
9011             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9012      &        - 0.5d0*(s8d+s12d)
9013 #else
9014             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9015      &        - 0.5d0*s12d
9016 #endif
9017           enddo
9018         enddo
9019       enddo
9020 #ifdef MOMENT
9021       do kkk=1,5
9022         do lll=1,3
9023           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9024      &      achuj_tempd(1,1))
9025           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9026           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9027           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9028           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9029           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9030      &      vtemp4d(1))
9031           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9032           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9033           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9034         enddo
9035       enddo
9036 #endif
9037 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9038 cd     &  16*eel_turn6_num
9039 cd      goto 1112
9040       if (j.lt.nres-1) then
9041         j1=j+1
9042         j2=j-1
9043       else
9044         j1=j-1
9045         j2=j-2
9046       endif
9047       if (l.lt.nres-1) then
9048         l1=l+1
9049         l2=l-1
9050       else
9051         l1=l-1
9052         l2=l-2
9053       endif
9054       do ll=1,3
9055 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9056 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9057 cgrad        ghalf=0.5d0*ggg1(ll)
9058 cd        ghalf=0.0d0
9059         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9060         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9061         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9062      &    +ekont*derx_turn(ll,2,1)
9063         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9064         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9065      &    +ekont*derx_turn(ll,4,1)
9066         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9067         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9068         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9069 cgrad        ghalf=0.5d0*ggg2(ll)
9070 cd        ghalf=0.0d0
9071         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9072      &    +ekont*derx_turn(ll,2,2)
9073         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9074         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9075      &    +ekont*derx_turn(ll,4,2)
9076         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9077         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9078         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9079       enddo
9080 cd      goto 1112
9081 cgrad      do m=i+1,j-1
9082 cgrad        do ll=1,3
9083 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9084 cgrad        enddo
9085 cgrad      enddo
9086 cgrad      do m=k+1,l-1
9087 cgrad        do ll=1,3
9088 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9089 cgrad        enddo
9090 cgrad      enddo
9091 cgrad1112  continue
9092 cgrad      do m=i+2,j2
9093 cgrad        do ll=1,3
9094 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9095 cgrad        enddo
9096 cgrad      enddo
9097 cgrad      do m=k+2,l2
9098 cgrad        do ll=1,3
9099 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9100 cgrad        enddo
9101 cgrad      enddo
9102 cd      do iii=1,nres-3
9103 cd        write (2,*) iii,g_corr6_loc(iii)
9104 cd      enddo
9105       eello_turn6=ekont*eel_turn6
9106 cd      write (2,*) 'ekont',ekont
9107 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9108       return
9109       end
9110
9111 C-----------------------------------------------------------------------------
9112       double precision function scalar(u,v)
9113 !DIR$ INLINEALWAYS scalar
9114 #ifndef OSF
9115 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9116 #endif
9117       implicit none
9118       double precision u(3),v(3)
9119 cd      double precision sc
9120 cd      integer i
9121 cd      sc=0.0d0
9122 cd      do i=1,3
9123 cd        sc=sc+u(i)*v(i)
9124 cd      enddo
9125 cd      scalar=sc
9126
9127       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9128       return
9129       end
9130 crc-------------------------------------------------
9131       SUBROUTINE MATVEC2(A1,V1,V2)
9132 !DIR$ INLINEALWAYS MATVEC2
9133 #ifndef OSF
9134 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9135 #endif
9136       implicit real*8 (a-h,o-z)
9137       include 'DIMENSIONS'
9138       DIMENSION A1(2,2),V1(2),V2(2)
9139 c      DO 1 I=1,2
9140 c        VI=0.0
9141 c        DO 3 K=1,2
9142 c    3     VI=VI+A1(I,K)*V1(K)
9143 c        Vaux(I)=VI
9144 c    1 CONTINUE
9145
9146       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9147       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9148
9149       v2(1)=vaux1
9150       v2(2)=vaux2
9151       END
9152 C---------------------------------------
9153       SUBROUTINE MATMAT2(A1,A2,A3)
9154 #ifndef OSF
9155 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9156 #endif
9157       implicit real*8 (a-h,o-z)
9158       include 'DIMENSIONS'
9159       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9160 c      DIMENSION AI3(2,2)
9161 c        DO  J=1,2
9162 c          A3IJ=0.0
9163 c          DO K=1,2
9164 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9165 c          enddo
9166 c          A3(I,J)=A3IJ
9167 c       enddo
9168 c      enddo
9169
9170       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9171       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9172       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9173       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9174
9175       A3(1,1)=AI3_11
9176       A3(2,1)=AI3_21
9177       A3(1,2)=AI3_12
9178       A3(2,2)=AI3_22
9179       END
9180
9181 c-------------------------------------------------------------------------
9182       double precision function scalar2(u,v)
9183 !DIR$ INLINEALWAYS scalar2
9184       implicit none
9185       double precision u(2),v(2)
9186       double precision sc
9187       integer i
9188       scalar2=u(1)*v(1)+u(2)*v(2)
9189       return
9190       end
9191
9192 C-----------------------------------------------------------------------------
9193
9194       subroutine transpose2(a,at)
9195 !DIR$ INLINEALWAYS transpose2
9196 #ifndef OSF
9197 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9198 #endif
9199       implicit none
9200       double precision a(2,2),at(2,2)
9201       at(1,1)=a(1,1)
9202       at(1,2)=a(2,1)
9203       at(2,1)=a(1,2)
9204       at(2,2)=a(2,2)
9205       return
9206       end
9207 c--------------------------------------------------------------------------
9208       subroutine transpose(n,a,at)
9209       implicit none
9210       integer n,i,j
9211       double precision a(n,n),at(n,n)
9212       do i=1,n
9213         do j=1,n
9214           at(j,i)=a(i,j)
9215         enddo
9216       enddo
9217       return
9218       end
9219 C---------------------------------------------------------------------------
9220       subroutine prodmat3(a1,a2,kk,transp,prod)
9221 !DIR$ INLINEALWAYS prodmat3
9222 #ifndef OSF
9223 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9224 #endif
9225       implicit none
9226       integer i,j
9227       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9228       logical transp
9229 crc      double precision auxmat(2,2),prod_(2,2)
9230
9231       if (transp) then
9232 crc        call transpose2(kk(1,1),auxmat(1,1))
9233 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9234 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9235
9236            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9237      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9238            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9239      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9240            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9241      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9242            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9243      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9244
9245       else
9246 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9247 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9248
9249            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9250      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9251            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9252      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9253            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9254      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9255            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9256      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9257
9258       endif
9259 c      call transpose2(a2(1,1),a2t(1,1))
9260
9261 crc      print *,transp
9262 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9263 crc      print *,((prod(i,j),i=1,2),j=1,2)
9264
9265       return
9266       end
9267