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=iabs(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 C triple bond artifac removal
1596              do k=j+1,iend(i,iint)
1597 C search over all next residues
1598               if (dyn_ss_mask(k)) then
1599 C check if they are cysteins
1600 C              write(iout,*) 'k=',k
1601               call triple_ssbond_ene(i,j,k,evdwij)
1602 C call the energy function that removes the artifical triple disulfide
1603 C bond the soubroutine is located in ssMD.F
1604               evdw=evdw+evdwij
1605               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1606      &                        'evdw',i,j,evdwij,'tss'
1607               endif!dyn_ss_mask(k)
1608              enddo! k
1609             ELSE
1610 C            cycle
1611             ind=ind+1
1612             itypj=itype(j)
1613 c            dscj_inv=dsc_inv(itypj)
1614             dscj_inv=vbld_inv(j+nres)
1615 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1616 c     &       1.0d0/vbld(j+nres)
1617 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1618             sig0ij=sigma(itypi,itypj)
1619             chi1=chi(itypi,itypj)
1620             chi2=chi(itypj,itypi)
1621             chi12=chi1*chi2
1622             chip1=chip(itypi)
1623             chip2=chip(itypj)
1624             chip12=chip1*chip2
1625             alf1=alp(itypi)
1626             alf2=alp(itypj)
1627             alf12=0.5D0*(alf1+alf2)
1628 C For diagnostics only!!!
1629 c           chi1=0.0D0
1630 c           chi2=0.0D0
1631 c           chi12=0.0D0
1632 c           chip1=0.0D0
1633 c           chip2=0.0D0
1634 c           chip12=0.0D0
1635 c           alf1=0.0D0
1636 c           alf2=0.0D0
1637 c           alf12=0.0D0
1638             xj=c(1,nres+j)-xi
1639             yj=c(2,nres+j)-yi
1640             zj=c(3,nres+j)-zi
1641             dxj=dc_norm(1,nres+j)
1642             dyj=dc_norm(2,nres+j)
1643             dzj=dc_norm(3,nres+j)
1644 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1645 c            write (iout,*) "j",j," dc_norm",
1646 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1647             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1648             rij=dsqrt(rrij)
1649 C Calculate angle-dependent terms of energy and contributions to their
1650 C derivatives.
1651             call sc_angular
1652             sigsq=1.0D0/sigsq
1653             sig=sig0ij*dsqrt(sigsq)
1654             rij_shift=1.0D0/rij-sig+sig0ij
1655 c for diagnostics; uncomment
1656 c            rij_shift=1.2*sig0ij
1657 C I hate to put IF's in the loops, but here don't have another choice!!!!
1658             if (rij_shift.le.0.0D0) then
1659               evdw=1.0D20
1660 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1661 cd     &        restyp(itypi),i,restyp(itypj),j,
1662 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1663               return
1664             endif
1665             sigder=-sig*sigsq
1666 c---------------------------------------------------------------
1667             rij_shift=1.0D0/rij_shift
1668             fac=rij_shift**expon
1669             e1=fac*fac*aa(itypi,itypj)
1670             e2=fac*bb(itypi,itypj)
1671             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1672             eps2der=evdwij*eps3rt
1673             eps3der=evdwij*eps2rt
1674 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1675 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1676             evdwij=evdwij*eps2rt*eps3rt
1677 #ifdef TSCSC
1678             if (bb(itypi,itypj).gt.0) then
1679                evdw_p=evdw_p+evdwij
1680             else
1681                evdw_m=evdw_m+evdwij
1682             endif
1683 #else
1684             evdw=evdw+evdwij
1685 #endif
1686             if (lprn) then
1687             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1688             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1689             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1690      &        restyp(itypi),i,restyp(itypj),j,
1691      &        epsi,sigm,chi1,chi2,chip1,chip2,
1692      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1693      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1694      &        evdwij
1695             endif
1696
1697             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1698      &                        'evdw',i,j,evdwij
1699
1700 C Calculate gradient components.
1701             e1=e1*eps1*eps2rt**2*eps3rt**2
1702             fac=-expon*(e1+evdwij)*rij_shift
1703             sigder=fac*sigder
1704             fac=rij*fac
1705 c            fac=0.0d0
1706 C Calculate the radial part of the gradient
1707             gg(1)=xj*fac
1708             gg(2)=yj*fac
1709             gg(3)=zj*fac
1710 C Calculate angular part of the gradient.
1711 #ifdef TSCSC
1712             if (bb(itypi,itypj).gt.0) then
1713                call sc_grad
1714             else
1715                call sc_grad_T
1716             endif
1717 #else
1718             call sc_grad
1719 #endif
1720             ENDIF    ! dyn_ss
1721           enddo      ! j
1722         enddo        ! iint
1723       enddo          ! i
1724 c      write (iout,*) "Number of loop steps in EGB:",ind
1725 cccc      energy_dec=.false.
1726       return
1727       end
1728 C-----------------------------------------------------------------------------
1729       subroutine egbv(evdw,evdw_p,evdw_m)
1730 C
1731 C This subroutine calculates the interaction energy of nonbonded side chains
1732 C assuming the Gay-Berne-Vorobjev potential of interaction.
1733 C
1734       implicit real*8 (a-h,o-z)
1735       include 'DIMENSIONS'
1736       include 'COMMON.GEO'
1737       include 'COMMON.VAR'
1738       include 'COMMON.LOCAL'
1739       include 'COMMON.CHAIN'
1740       include 'COMMON.DERIV'
1741       include 'COMMON.NAMES'
1742       include 'COMMON.INTERACT'
1743       include 'COMMON.IOUNITS'
1744       include 'COMMON.CALC'
1745       common /srutu/ icall
1746       logical lprn
1747       evdw=0.0D0
1748 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1749       evdw=0.0D0
1750       lprn=.false.
1751 c     if (icall.eq.0) lprn=.true.
1752       ind=0
1753       do i=iatsc_s,iatsc_e
1754         itypi=itype(i)
1755         itypi1=itype(i+1)
1756         xi=c(1,nres+i)
1757         yi=c(2,nres+i)
1758         zi=c(3,nres+i)
1759         dxi=dc_norm(1,nres+i)
1760         dyi=dc_norm(2,nres+i)
1761         dzi=dc_norm(3,nres+i)
1762 c        dsci_inv=dsc_inv(itypi)
1763         dsci_inv=vbld_inv(i+nres)
1764 C
1765 C Calculate SC interaction energy.
1766 C
1767         do iint=1,nint_gr(i)
1768           do j=istart(i,iint),iend(i,iint)
1769             ind=ind+1
1770             itypj=itype(j)
1771 c            dscj_inv=dsc_inv(itypj)
1772             dscj_inv=vbld_inv(j+nres)
1773             sig0ij=sigma(itypi,itypj)
1774             r0ij=r0(itypi,itypj)
1775             chi1=chi(itypi,itypj)
1776             chi2=chi(itypj,itypi)
1777             chi12=chi1*chi2
1778             chip1=chip(itypi)
1779             chip2=chip(itypj)
1780             chip12=chip1*chip2
1781             alf1=alp(itypi)
1782             alf2=alp(itypj)
1783             alf12=0.5D0*(alf1+alf2)
1784 C For diagnostics only!!!
1785 c           chi1=0.0D0
1786 c           chi2=0.0D0
1787 c           chi12=0.0D0
1788 c           chip1=0.0D0
1789 c           chip2=0.0D0
1790 c           chip12=0.0D0
1791 c           alf1=0.0D0
1792 c           alf2=0.0D0
1793 c           alf12=0.0D0
1794             xj=c(1,nres+j)-xi
1795             yj=c(2,nres+j)-yi
1796             zj=c(3,nres+j)-zi
1797             dxj=dc_norm(1,nres+j)
1798             dyj=dc_norm(2,nres+j)
1799             dzj=dc_norm(3,nres+j)
1800             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1801             rij=dsqrt(rrij)
1802 C Calculate angle-dependent terms of energy and contributions to their
1803 C derivatives.
1804             call sc_angular
1805             sigsq=1.0D0/sigsq
1806             sig=sig0ij*dsqrt(sigsq)
1807             rij_shift=1.0D0/rij-sig+r0ij
1808 C I hate to put IF's in the loops, but here don't have another choice!!!!
1809             if (rij_shift.le.0.0D0) then
1810               evdw=1.0D20
1811               return
1812             endif
1813             sigder=-sig*sigsq
1814 c---------------------------------------------------------------
1815             rij_shift=1.0D0/rij_shift
1816             fac=rij_shift**expon
1817             e1=fac*fac*aa(itypi,itypj)
1818             e2=fac*bb(itypi,itypj)
1819             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1820             eps2der=evdwij*eps3rt
1821             eps3der=evdwij*eps2rt
1822             fac_augm=rrij**expon
1823             e_augm=augm(itypi,itypj)*fac_augm
1824             evdwij=evdwij*eps2rt*eps3rt
1825 #ifdef TSCSC
1826             if (bb(itypi,itypj).gt.0) then
1827                evdw_p=evdw_p+evdwij+e_augm
1828             else
1829                evdw_m=evdw_m+evdwij+e_augm
1830             endif
1831 #else
1832             evdw=evdw+evdwij+e_augm
1833 #endif
1834             if (lprn) then
1835             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1836             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1837             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1838      &        restyp(itypi),i,restyp(itypj),j,
1839      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1840      &        chi1,chi2,chip1,chip2,
1841      &        eps1,eps2rt**2,eps3rt**2,
1842      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1843      &        evdwij+e_augm
1844             endif
1845 C Calculate gradient components.
1846             e1=e1*eps1*eps2rt**2*eps3rt**2
1847             fac=-expon*(e1+evdwij)*rij_shift
1848             sigder=fac*sigder
1849             fac=rij*fac-2*expon*rrij*e_augm
1850 C Calculate the radial part of the gradient
1851             gg(1)=xj*fac
1852             gg(2)=yj*fac
1853             gg(3)=zj*fac
1854 C Calculate angular part of the gradient.
1855 #ifdef TSCSC
1856             if (bb(itypi,itypj).gt.0) then
1857                call sc_grad
1858             else
1859                call sc_grad_T
1860             endif
1861 #else
1862             call sc_grad
1863 #endif
1864           enddo      ! j
1865         enddo        ! iint
1866       enddo          ! i
1867       end
1868 C-----------------------------------------------------------------------------
1869       subroutine sc_angular
1870 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1871 C om12. Called by ebp, egb, and egbv.
1872       implicit none
1873       include 'COMMON.CALC'
1874       include 'COMMON.IOUNITS'
1875       erij(1)=xj*rij
1876       erij(2)=yj*rij
1877       erij(3)=zj*rij
1878       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1879       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1880       om12=dxi*dxj+dyi*dyj+dzi*dzj
1881       chiom12=chi12*om12
1882 C Calculate eps1(om12) and its derivative in om12
1883       faceps1=1.0D0-om12*chiom12
1884       faceps1_inv=1.0D0/faceps1
1885       eps1=dsqrt(faceps1_inv)
1886 C Following variable is eps1*deps1/dom12
1887       eps1_om12=faceps1_inv*chiom12
1888 c diagnostics only
1889 c      faceps1_inv=om12
1890 c      eps1=om12
1891 c      eps1_om12=1.0d0
1892 c      write (iout,*) "om12",om12," eps1",eps1
1893 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1894 C and om12.
1895       om1om2=om1*om2
1896       chiom1=chi1*om1
1897       chiom2=chi2*om2
1898       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1899       sigsq=1.0D0-facsig*faceps1_inv
1900       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1901       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1902       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1903 c diagnostics only
1904 c      sigsq=1.0d0
1905 c      sigsq_om1=0.0d0
1906 c      sigsq_om2=0.0d0
1907 c      sigsq_om12=0.0d0
1908 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1909 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1910 c     &    " eps1",eps1
1911 C Calculate eps2 and its derivatives in om1, om2, and om12.
1912       chipom1=chip1*om1
1913       chipom2=chip2*om2
1914       chipom12=chip12*om12
1915       facp=1.0D0-om12*chipom12
1916       facp_inv=1.0D0/facp
1917       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1918 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1919 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1920 C Following variable is the square root of eps2
1921       eps2rt=1.0D0-facp1*facp_inv
1922 C Following three variables are the derivatives of the square root of eps
1923 C in om1, om2, and om12.
1924       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1925       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1926       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1927 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1928       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1929 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1930 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1931 c     &  " eps2rt_om12",eps2rt_om12
1932 C Calculate whole angle-dependent part of epsilon and contributions
1933 C to its derivatives
1934       return
1935       end
1936
1937 C----------------------------------------------------------------------------
1938       subroutine sc_grad_T
1939       implicit real*8 (a-h,o-z)
1940       include 'DIMENSIONS'
1941       include 'COMMON.CHAIN'
1942       include 'COMMON.DERIV'
1943       include 'COMMON.CALC'
1944       include 'COMMON.IOUNITS'
1945       double precision dcosom1(3),dcosom2(3)
1946       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1947       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1948       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1949      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1950 c diagnostics only
1951 c      eom1=0.0d0
1952 c      eom2=0.0d0
1953 c      eom12=evdwij*eps1_om12
1954 c end diagnostics
1955 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1956 c     &  " sigder",sigder
1957 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1958 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1959       do k=1,3
1960         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1961         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1962       enddo
1963       do k=1,3
1964         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1965       enddo
1966 c      write (iout,*) "gg",(gg(k),k=1,3)
1967       do k=1,3
1968         gvdwxT(k,i)=gvdwxT(k,i)-gg(k)
1969      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1970      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1971         gvdwxT(k,j)=gvdwxT(k,j)+gg(k)
1972      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1973      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1974 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1975 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1976 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1977 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1978       enddo
1979 C
1980 C Calculate the components of the gradient in DC and X
1981 C
1982 cgrad      do k=i,j-1
1983 cgrad        do l=1,3
1984 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1985 cgrad        enddo
1986 cgrad      enddo
1987       do l=1,3
1988         gvdwcT(l,i)=gvdwcT(l,i)-gg(l)
1989         gvdwcT(l,j)=gvdwcT(l,j)+gg(l)
1990       enddo
1991       return
1992       end
1993
1994 C----------------------------------------------------------------------------
1995       subroutine sc_grad
1996       implicit real*8 (a-h,o-z)
1997       include 'DIMENSIONS'
1998       include 'COMMON.CHAIN'
1999       include 'COMMON.DERIV'
2000       include 'COMMON.CALC'
2001       include 'COMMON.IOUNITS'
2002       double precision dcosom1(3),dcosom2(3)
2003       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2004       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2005       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2006      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2007 c diagnostics only
2008 c      eom1=0.0d0
2009 c      eom2=0.0d0
2010 c      eom12=evdwij*eps1_om12
2011 c end diagnostics
2012 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2013 c     &  " sigder",sigder
2014 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2015 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2016       do k=1,3
2017         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2018         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2019       enddo
2020       do k=1,3
2021         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2022       enddo
2023 c      write (iout,*) "gg",(gg(k),k=1,3)
2024       do k=1,3
2025         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2026      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2027      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2028         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2029      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2030      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2031 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2032 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2033 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2034 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2035       enddo
2036 C
2037 C Calculate the components of the gradient in DC and X
2038 C
2039 cgrad      do k=i,j-1
2040 cgrad        do l=1,3
2041 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2042 cgrad        enddo
2043 cgrad      enddo
2044       do l=1,3
2045         gvdwc(l,i)=gvdwc(l,i)-gg(l)
2046         gvdwc(l,j)=gvdwc(l,j)+gg(l)
2047       enddo
2048       return
2049       end
2050 C-----------------------------------------------------------------------
2051       subroutine e_softsphere(evdw)
2052 C
2053 C This subroutine calculates the interaction energy of nonbonded side chains
2054 C assuming the LJ potential of interaction.
2055 C
2056       implicit real*8 (a-h,o-z)
2057       include 'DIMENSIONS'
2058       parameter (accur=1.0d-10)
2059       include 'COMMON.GEO'
2060       include 'COMMON.VAR'
2061       include 'COMMON.LOCAL'
2062       include 'COMMON.CHAIN'
2063       include 'COMMON.DERIV'
2064       include 'COMMON.INTERACT'
2065       include 'COMMON.TORSION'
2066       include 'COMMON.SBRIDGE'
2067       include 'COMMON.NAMES'
2068       include 'COMMON.IOUNITS'
2069       include 'COMMON.CONTACTS'
2070       dimension gg(3)
2071 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2072       evdw=0.0D0
2073       do i=iatsc_s,iatsc_e
2074         itypi=itype(i)
2075         itypi1=itype(i+1)
2076         xi=c(1,nres+i)
2077         yi=c(2,nres+i)
2078         zi=c(3,nres+i)
2079 C
2080 C Calculate SC interaction energy.
2081 C
2082         do iint=1,nint_gr(i)
2083 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2084 cd   &                  'iend=',iend(i,iint)
2085           do j=istart(i,iint),iend(i,iint)
2086             itypj=itype(j)
2087             xj=c(1,nres+j)-xi
2088             yj=c(2,nres+j)-yi
2089             zj=c(3,nres+j)-zi
2090             rij=xj*xj+yj*yj+zj*zj
2091 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2092             r0ij=r0(itypi,itypj)
2093             r0ijsq=r0ij*r0ij
2094 c            print *,i,j,r0ij,dsqrt(rij)
2095             if (rij.lt.r0ijsq) then
2096               evdwij=0.25d0*(rij-r0ijsq)**2
2097               fac=rij-r0ijsq
2098             else
2099               evdwij=0.0d0
2100               fac=0.0d0
2101             endif
2102             evdw=evdw+evdwij
2103 C
2104 C Calculate the components of the gradient in DC and X
2105 C
2106             gg(1)=xj*fac
2107             gg(2)=yj*fac
2108             gg(3)=zj*fac
2109             do k=1,3
2110               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2111               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2112               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2113               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2114             enddo
2115 cgrad            do k=i,j-1
2116 cgrad              do l=1,3
2117 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2118 cgrad              enddo
2119 cgrad            enddo
2120           enddo ! j
2121         enddo ! iint
2122       enddo ! i
2123       return
2124       end
2125 C--------------------------------------------------------------------------
2126       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2127      &              eello_turn4)
2128 C
2129 C Soft-sphere potential of p-p interaction
2130 C
2131       implicit real*8 (a-h,o-z)
2132       include 'DIMENSIONS'
2133       include 'COMMON.CONTROL'
2134       include 'COMMON.IOUNITS'
2135       include 'COMMON.GEO'
2136       include 'COMMON.VAR'
2137       include 'COMMON.LOCAL'
2138       include 'COMMON.CHAIN'
2139       include 'COMMON.DERIV'
2140       include 'COMMON.INTERACT'
2141       include 'COMMON.CONTACTS'
2142       include 'COMMON.TORSION'
2143       include 'COMMON.VECTORS'
2144       include 'COMMON.FFIELD'
2145       dimension ggg(3)
2146 cd      write(iout,*) 'In EELEC_soft_sphere'
2147       ees=0.0D0
2148       evdw1=0.0D0
2149       eel_loc=0.0d0
2150       eello_turn3=0.0d0
2151       eello_turn4=0.0d0
2152       ind=0
2153       do i=iatel_s,iatel_e
2154         dxi=dc(1,i)
2155         dyi=dc(2,i)
2156         dzi=dc(3,i)
2157         xmedi=c(1,i)+0.5d0*dxi
2158         ymedi=c(2,i)+0.5d0*dyi
2159         zmedi=c(3,i)+0.5d0*dzi
2160         num_conti=0
2161 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2162         do j=ielstart(i),ielend(i)
2163           ind=ind+1
2164           iteli=itel(i)
2165           itelj=itel(j)
2166           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2167           r0ij=rpp(iteli,itelj)
2168           r0ijsq=r0ij*r0ij
2169           dxj=dc(1,j)
2170           dyj=dc(2,j)
2171           dzj=dc(3,j)
2172           xj=c(1,j)+0.5D0*dxj-xmedi
2173           yj=c(2,j)+0.5D0*dyj-ymedi
2174           zj=c(3,j)+0.5D0*dzj-zmedi
2175           rij=xj*xj+yj*yj+zj*zj
2176           if (rij.lt.r0ijsq) then
2177             evdw1ij=0.25d0*(rij-r0ijsq)**2
2178             fac=rij-r0ijsq
2179           else
2180             evdw1ij=0.0d0
2181             fac=0.0d0
2182           endif
2183           evdw1=evdw1+evdw1ij
2184 C
2185 C Calculate contributions to the Cartesian gradient.
2186 C
2187           ggg(1)=fac*xj
2188           ggg(2)=fac*yj
2189           ggg(3)=fac*zj
2190           do k=1,3
2191             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2192             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2193           enddo
2194 *
2195 * Loop over residues i+1 thru j-1.
2196 *
2197 cgrad          do k=i+1,j-1
2198 cgrad            do l=1,3
2199 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2200 cgrad            enddo
2201 cgrad          enddo
2202         enddo ! j
2203       enddo   ! i
2204 cgrad      do i=nnt,nct-1
2205 cgrad        do k=1,3
2206 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2207 cgrad        enddo
2208 cgrad        do j=i+1,nct-1
2209 cgrad          do k=1,3
2210 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2211 cgrad          enddo
2212 cgrad        enddo
2213 cgrad      enddo
2214       return
2215       end
2216 c------------------------------------------------------------------------------
2217       subroutine vec_and_deriv
2218       implicit real*8 (a-h,o-z)
2219       include 'DIMENSIONS'
2220 #ifdef MPI
2221       include 'mpif.h'
2222 #endif
2223       include 'COMMON.IOUNITS'
2224       include 'COMMON.GEO'
2225       include 'COMMON.VAR'
2226       include 'COMMON.LOCAL'
2227       include 'COMMON.CHAIN'
2228       include 'COMMON.VECTORS'
2229       include 'COMMON.SETUP'
2230       include 'COMMON.TIME1'
2231       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2232 C Compute the local reference systems. For reference system (i), the
2233 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2234 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2235 #ifdef PARVEC
2236       do i=ivec_start,ivec_end
2237 #else
2238       do i=1,nres-1
2239 #endif
2240           if (i.eq.nres-1) then
2241 C Case of the last full residue
2242 C Compute the Z-axis
2243             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2244             costh=dcos(pi-theta(nres))
2245             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2246             do k=1,3
2247               uz(k,i)=fac*uz(k,i)
2248             enddo
2249 C Compute the derivatives of uz
2250             uzder(1,1,1)= 0.0d0
2251             uzder(2,1,1)=-dc_norm(3,i-1)
2252             uzder(3,1,1)= dc_norm(2,i-1)
2253             uzder(1,2,1)= dc_norm(3,i-1)
2254             uzder(2,2,1)= 0.0d0
2255             uzder(3,2,1)=-dc_norm(1,i-1)
2256             uzder(1,3,1)=-dc_norm(2,i-1)
2257             uzder(2,3,1)= dc_norm(1,i-1)
2258             uzder(3,3,1)= 0.0d0
2259             uzder(1,1,2)= 0.0d0
2260             uzder(2,1,2)= dc_norm(3,i)
2261             uzder(3,1,2)=-dc_norm(2,i)
2262             uzder(1,2,2)=-dc_norm(3,i)
2263             uzder(2,2,2)= 0.0d0
2264             uzder(3,2,2)= dc_norm(1,i)
2265             uzder(1,3,2)= dc_norm(2,i)
2266             uzder(2,3,2)=-dc_norm(1,i)
2267             uzder(3,3,2)= 0.0d0
2268 C Compute the Y-axis
2269             facy=fac
2270             do k=1,3
2271               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2272             enddo
2273 C Compute the derivatives of uy
2274             do j=1,3
2275               do k=1,3
2276                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2277      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2278                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2279               enddo
2280               uyder(j,j,1)=uyder(j,j,1)-costh
2281               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2282             enddo
2283             do j=1,2
2284               do k=1,3
2285                 do l=1,3
2286                   uygrad(l,k,j,i)=uyder(l,k,j)
2287                   uzgrad(l,k,j,i)=uzder(l,k,j)
2288                 enddo
2289               enddo
2290             enddo
2291             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2292             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2293             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2294             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2295           else
2296 C Other residues
2297 C Compute the Z-axis
2298             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2299             costh=dcos(pi-theta(i+2))
2300             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2301             do k=1,3
2302               uz(k,i)=fac*uz(k,i)
2303             enddo
2304 C Compute the derivatives of uz
2305             uzder(1,1,1)= 0.0d0
2306             uzder(2,1,1)=-dc_norm(3,i+1)
2307             uzder(3,1,1)= dc_norm(2,i+1)
2308             uzder(1,2,1)= dc_norm(3,i+1)
2309             uzder(2,2,1)= 0.0d0
2310             uzder(3,2,1)=-dc_norm(1,i+1)
2311             uzder(1,3,1)=-dc_norm(2,i+1)
2312             uzder(2,3,1)= dc_norm(1,i+1)
2313             uzder(3,3,1)= 0.0d0
2314             uzder(1,1,2)= 0.0d0
2315             uzder(2,1,2)= dc_norm(3,i)
2316             uzder(3,1,2)=-dc_norm(2,i)
2317             uzder(1,2,2)=-dc_norm(3,i)
2318             uzder(2,2,2)= 0.0d0
2319             uzder(3,2,2)= dc_norm(1,i)
2320             uzder(1,3,2)= dc_norm(2,i)
2321             uzder(2,3,2)=-dc_norm(1,i)
2322             uzder(3,3,2)= 0.0d0
2323 C Compute the Y-axis
2324             facy=fac
2325             do k=1,3
2326               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2327             enddo
2328 C Compute the derivatives of uy
2329             do j=1,3
2330               do k=1,3
2331                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2332      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2333                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2334               enddo
2335               uyder(j,j,1)=uyder(j,j,1)-costh
2336               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2337             enddo
2338             do j=1,2
2339               do k=1,3
2340                 do l=1,3
2341                   uygrad(l,k,j,i)=uyder(l,k,j)
2342                   uzgrad(l,k,j,i)=uzder(l,k,j)
2343                 enddo
2344               enddo
2345             enddo
2346             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2347             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2348             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2349             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2350           endif
2351       enddo
2352       do i=1,nres-1
2353         vbld_inv_temp(1)=vbld_inv(i+1)
2354         if (i.lt.nres-1) then
2355           vbld_inv_temp(2)=vbld_inv(i+2)
2356           else
2357           vbld_inv_temp(2)=vbld_inv(i)
2358           endif
2359         do j=1,2
2360           do k=1,3
2361             do l=1,3
2362               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2363               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2364             enddo
2365           enddo
2366         enddo
2367       enddo
2368 #if defined(PARVEC) && defined(MPI)
2369       if (nfgtasks1.gt.1) then
2370         time00=MPI_Wtime()
2371 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2372 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2373 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2374         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2375      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2376      &   FG_COMM1,IERR)
2377         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2378      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2379      &   FG_COMM1,IERR)
2380         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2381      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2382      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2383         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2384      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2385      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2386         time_gather=time_gather+MPI_Wtime()-time00
2387       endif
2388 c      if (fg_rank.eq.0) then
2389 c        write (iout,*) "Arrays UY and UZ"
2390 c        do i=1,nres-1
2391 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2392 c     &     (uz(k,i),k=1,3)
2393 c        enddo
2394 c      endif
2395 #endif
2396       return
2397       end
2398 C-----------------------------------------------------------------------------
2399       subroutine check_vecgrad
2400       implicit real*8 (a-h,o-z)
2401       include 'DIMENSIONS'
2402       include 'COMMON.IOUNITS'
2403       include 'COMMON.GEO'
2404       include 'COMMON.VAR'
2405       include 'COMMON.LOCAL'
2406       include 'COMMON.CHAIN'
2407       include 'COMMON.VECTORS'
2408       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2409       dimension uyt(3,maxres),uzt(3,maxres)
2410       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2411       double precision delta /1.0d-7/
2412       call vec_and_deriv
2413 cd      do i=1,nres
2414 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2415 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2416 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2417 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2418 cd     &     (dc_norm(if90,i),if90=1,3)
2419 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2420 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2421 cd          write(iout,'(a)')
2422 cd      enddo
2423       do i=1,nres
2424         do j=1,2
2425           do k=1,3
2426             do l=1,3
2427               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2428               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2429             enddo
2430           enddo
2431         enddo
2432       enddo
2433       call vec_and_deriv
2434       do i=1,nres
2435         do j=1,3
2436           uyt(j,i)=uy(j,i)
2437           uzt(j,i)=uz(j,i)
2438         enddo
2439       enddo
2440       do i=1,nres
2441 cd        write (iout,*) 'i=',i
2442         do k=1,3
2443           erij(k)=dc_norm(k,i)
2444         enddo
2445         do j=1,3
2446           do k=1,3
2447             dc_norm(k,i)=erij(k)
2448           enddo
2449           dc_norm(j,i)=dc_norm(j,i)+delta
2450 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2451 c          do k=1,3
2452 c            dc_norm(k,i)=dc_norm(k,i)/fac
2453 c          enddo
2454 c          write (iout,*) (dc_norm(k,i),k=1,3)
2455 c          write (iout,*) (erij(k),k=1,3)
2456           call vec_and_deriv
2457           do k=1,3
2458             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2459             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2460             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2461             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2462           enddo
2463 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2464 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2465 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2466         enddo
2467         do k=1,3
2468           dc_norm(k,i)=erij(k)
2469         enddo
2470 cd        do k=1,3
2471 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2472 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2473 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2474 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2475 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2476 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2477 cd          write (iout,'(a)')
2478 cd        enddo
2479       enddo
2480       return
2481       end
2482 C--------------------------------------------------------------------------
2483       subroutine set_matrices
2484       implicit real*8 (a-h,o-z)
2485       include 'DIMENSIONS'
2486 #ifdef MPI
2487       include "mpif.h"
2488       include "COMMON.SETUP"
2489       integer IERR
2490       integer status(MPI_STATUS_SIZE)
2491 #endif
2492       include 'COMMON.IOUNITS'
2493       include 'COMMON.GEO'
2494       include 'COMMON.VAR'
2495       include 'COMMON.LOCAL'
2496       include 'COMMON.CHAIN'
2497       include 'COMMON.DERIV'
2498       include 'COMMON.INTERACT'
2499       include 'COMMON.CONTACTS'
2500       include 'COMMON.TORSION'
2501       include 'COMMON.VECTORS'
2502       include 'COMMON.FFIELD'
2503       double precision auxvec(2),auxmat(2,2)
2504 C
2505 C Compute the virtual-bond-torsional-angle dependent quantities needed
2506 C to calculate the el-loc multibody terms of various order.
2507 C
2508 #ifdef PARMAT
2509       do i=ivec_start+2,ivec_end+2
2510 #else
2511       do i=3,nres+1
2512 #endif
2513         if (i .lt. nres+1) then
2514           sin1=dsin(phi(i))
2515           cos1=dcos(phi(i))
2516           sintab(i-2)=sin1
2517           costab(i-2)=cos1
2518           obrot(1,i-2)=cos1
2519           obrot(2,i-2)=sin1
2520           sin2=dsin(2*phi(i))
2521           cos2=dcos(2*phi(i))
2522           sintab2(i-2)=sin2
2523           costab2(i-2)=cos2
2524           obrot2(1,i-2)=cos2
2525           obrot2(2,i-2)=sin2
2526           Ug(1,1,i-2)=-cos1
2527           Ug(1,2,i-2)=-sin1
2528           Ug(2,1,i-2)=-sin1
2529           Ug(2,2,i-2)= cos1
2530           Ug2(1,1,i-2)=-cos2
2531           Ug2(1,2,i-2)=-sin2
2532           Ug2(2,1,i-2)=-sin2
2533           Ug2(2,2,i-2)= cos2
2534         else
2535           costab(i-2)=1.0d0
2536           sintab(i-2)=0.0d0
2537           obrot(1,i-2)=1.0d0
2538           obrot(2,i-2)=0.0d0
2539           obrot2(1,i-2)=0.0d0
2540           obrot2(2,i-2)=0.0d0
2541           Ug(1,1,i-2)=1.0d0
2542           Ug(1,2,i-2)=0.0d0
2543           Ug(2,1,i-2)=0.0d0
2544           Ug(2,2,i-2)=1.0d0
2545           Ug2(1,1,i-2)=0.0d0
2546           Ug2(1,2,i-2)=0.0d0
2547           Ug2(2,1,i-2)=0.0d0
2548           Ug2(2,2,i-2)=0.0d0
2549         endif
2550         if (i .gt. 3 .and. i .lt. nres+1) then
2551           obrot_der(1,i-2)=-sin1
2552           obrot_der(2,i-2)= cos1
2553           Ugder(1,1,i-2)= sin1
2554           Ugder(1,2,i-2)=-cos1
2555           Ugder(2,1,i-2)=-cos1
2556           Ugder(2,2,i-2)=-sin1
2557           dwacos2=cos2+cos2
2558           dwasin2=sin2+sin2
2559           obrot2_der(1,i-2)=-dwasin2
2560           obrot2_der(2,i-2)= dwacos2
2561           Ug2der(1,1,i-2)= dwasin2
2562           Ug2der(1,2,i-2)=-dwacos2
2563           Ug2der(2,1,i-2)=-dwacos2
2564           Ug2der(2,2,i-2)=-dwasin2
2565         else
2566           obrot_der(1,i-2)=0.0d0
2567           obrot_der(2,i-2)=0.0d0
2568           Ugder(1,1,i-2)=0.0d0
2569           Ugder(1,2,i-2)=0.0d0
2570           Ugder(2,1,i-2)=0.0d0
2571           Ugder(2,2,i-2)=0.0d0
2572           obrot2_der(1,i-2)=0.0d0
2573           obrot2_der(2,i-2)=0.0d0
2574           Ug2der(1,1,i-2)=0.0d0
2575           Ug2der(1,2,i-2)=0.0d0
2576           Ug2der(2,1,i-2)=0.0d0
2577           Ug2der(2,2,i-2)=0.0d0
2578         endif
2579 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2580         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2581           iti = itortyp(itype(i-2))
2582         else
2583           iti=ntortyp+1
2584         endif
2585 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2586         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2587           iti1 = itortyp(itype(i-1))
2588         else
2589           iti1=ntortyp+1
2590         endif
2591 cd        write (iout,*) '*******i',i,' iti1',iti
2592 cd        write (iout,*) 'b1',b1(:,iti)
2593 cd        write (iout,*) 'b2',b2(:,iti)
2594 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2595 c        if (i .gt. iatel_s+2) then
2596         if (i .gt. nnt+2) then
2597           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2598           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2599           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2600      &    then
2601           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2602           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2603           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2604           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2605           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2606           endif
2607         else
2608           do k=1,2
2609             Ub2(k,i-2)=0.0d0
2610             Ctobr(k,i-2)=0.0d0
2611             Dtobr2(k,i-2)=0.0d0
2612             do l=1,2
2613               EUg(l,k,i-2)=0.0d0
2614               CUg(l,k,i-2)=0.0d0
2615               DUg(l,k,i-2)=0.0d0
2616               DtUg2(l,k,i-2)=0.0d0
2617             enddo
2618           enddo
2619         endif
2620         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2621         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2622         do k=1,2
2623           muder(k,i-2)=Ub2der(k,i-2)
2624         enddo
2625 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2626         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2627           iti1 = itortyp(itype(i-1))
2628         else
2629           iti1=ntortyp+1
2630         endif
2631         do k=1,2
2632           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2633         enddo
2634 cd        write (iout,*) 'mu ',mu(:,i-2)
2635 cd        write (iout,*) 'mu1',mu1(:,i-2)
2636 cd        write (iout,*) 'mu2',mu2(:,i-2)
2637         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2638      &  then
2639         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2640         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2641         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2642         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2643         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2644 C Vectors and matrices dependent on a single virtual-bond dihedral.
2645         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2646         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2647         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2648         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2649         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2650         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2651         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2652         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2653         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2654         endif
2655       enddo
2656 C Matrices dependent on two consecutive virtual-bond dihedrals.
2657 C The order of matrices is from left to right.
2658       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2659      &then
2660 c      do i=max0(ivec_start,2),ivec_end
2661       do i=2,nres-1
2662         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2663         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2664         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2665         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2666         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2667         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2668         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2669         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2670       enddo
2671       endif
2672 #if defined(MPI) && defined(PARMAT)
2673 #ifdef DEBUG
2674 c      if (fg_rank.eq.0) then
2675         write (iout,*) "Arrays UG and UGDER before GATHER"
2676         do i=1,nres-1
2677           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2678      &     ((ug(l,k,i),l=1,2),k=1,2),
2679      &     ((ugder(l,k,i),l=1,2),k=1,2)
2680         enddo
2681         write (iout,*) "Arrays UG2 and UG2DER"
2682         do i=1,nres-1
2683           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2684      &     ((ug2(l,k,i),l=1,2),k=1,2),
2685      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2686         enddo
2687         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2688         do i=1,nres-1
2689           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2690      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2691      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2692         enddo
2693         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2694         do i=1,nres-1
2695           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2696      &     costab(i),sintab(i),costab2(i),sintab2(i)
2697         enddo
2698         write (iout,*) "Array MUDER"
2699         do i=1,nres-1
2700           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2701         enddo
2702 c      endif
2703 #endif
2704       if (nfgtasks.gt.1) then
2705         time00=MPI_Wtime()
2706 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2707 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2708 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2709 #ifdef MATGATHER
2710         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2711      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2712      &   FG_COMM1,IERR)
2713         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2714      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2715      &   FG_COMM1,IERR)
2716         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2717      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2718      &   FG_COMM1,IERR)
2719         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2720      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2721      &   FG_COMM1,IERR)
2722         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2723      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2724      &   FG_COMM1,IERR)
2725         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2726      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2727      &   FG_COMM1,IERR)
2728         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2729      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2730      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2731         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2732      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2733      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2734         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2735      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2736      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2737         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2738      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2739      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2740         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2741      &  then
2742         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2743      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2744      &   FG_COMM1,IERR)
2745         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2746      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2747      &   FG_COMM1,IERR)
2748         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2749      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2750      &   FG_COMM1,IERR)
2751        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2752      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2753      &   FG_COMM1,IERR)
2754         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2755      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2756      &   FG_COMM1,IERR)
2757         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2758      &   ivec_count(fg_rank1),
2759      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2760      &   FG_COMM1,IERR)
2761         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2762      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2763      &   FG_COMM1,IERR)
2764         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2765      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2766      &   FG_COMM1,IERR)
2767         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2768      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2769      &   FG_COMM1,IERR)
2770         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2771      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2772      &   FG_COMM1,IERR)
2773         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2774      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2775      &   FG_COMM1,IERR)
2776         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2777      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2778      &   FG_COMM1,IERR)
2779         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2780      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2781      &   FG_COMM1,IERR)
2782         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2783      &   ivec_count(fg_rank1),
2784      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2785      &   FG_COMM1,IERR)
2786         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2787      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2788      &   FG_COMM1,IERR)
2789        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2790      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2791      &   FG_COMM1,IERR)
2792         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2793      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2794      &   FG_COMM1,IERR)
2795        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2796      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2797      &   FG_COMM1,IERR)
2798         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2799      &   ivec_count(fg_rank1),
2800      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2801      &   FG_COMM1,IERR)
2802         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2803      &   ivec_count(fg_rank1),
2804      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2805      &   FG_COMM1,IERR)
2806         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2807      &   ivec_count(fg_rank1),
2808      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2809      &   MPI_MAT2,FG_COMM1,IERR)
2810         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2811      &   ivec_count(fg_rank1),
2812      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2813      &   MPI_MAT2,FG_COMM1,IERR)
2814         endif
2815 #else
2816 c Passes matrix info through the ring
2817       isend=fg_rank1
2818       irecv=fg_rank1-1
2819       if (irecv.lt.0) irecv=nfgtasks1-1
2820       iprev=irecv
2821       inext=fg_rank1+1
2822       if (inext.ge.nfgtasks1) inext=0
2823       do i=1,nfgtasks1-1
2824 c        write (iout,*) "isend",isend," irecv",irecv
2825 c        call flush(iout)
2826         lensend=lentyp(isend)
2827         lenrecv=lentyp(irecv)
2828 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2829 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2830 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2831 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2832 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2833 c        write (iout,*) "Gather ROTAT1"
2834 c        call flush(iout)
2835 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2836 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2837 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2838 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2839 c        write (iout,*) "Gather ROTAT2"
2840 c        call flush(iout)
2841         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2842      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2843      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2844      &   iprev,4400+irecv,FG_COMM,status,IERR)
2845 c        write (iout,*) "Gather ROTAT_OLD"
2846 c        call flush(iout)
2847         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2848      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2849      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2850      &   iprev,5500+irecv,FG_COMM,status,IERR)
2851 c        write (iout,*) "Gather PRECOMP11"
2852 c        call flush(iout)
2853         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2854      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2855      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2856      &   iprev,6600+irecv,FG_COMM,status,IERR)
2857 c        write (iout,*) "Gather PRECOMP12"
2858 c        call flush(iout)
2859         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2860      &  then
2861         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2862      &   MPI_ROTAT2(lensend),inext,7700+isend,
2863      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2864      &   iprev,7700+irecv,FG_COMM,status,IERR)
2865 c        write (iout,*) "Gather PRECOMP21"
2866 c        call flush(iout)
2867         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2868      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2869      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2870      &   iprev,8800+irecv,FG_COMM,status,IERR)
2871 c        write (iout,*) "Gather PRECOMP22"
2872 c        call flush(iout)
2873         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2874      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2875      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2876      &   MPI_PRECOMP23(lenrecv),
2877      &   iprev,9900+irecv,FG_COMM,status,IERR)
2878 c        write (iout,*) "Gather PRECOMP23"
2879 c        call flush(iout)
2880         endif
2881         isend=irecv
2882         irecv=irecv-1
2883         if (irecv.lt.0) irecv=nfgtasks1-1
2884       enddo
2885 #endif
2886         time_gather=time_gather+MPI_Wtime()-time00
2887       endif
2888 #ifdef DEBUG
2889 c      if (fg_rank.eq.0) then
2890         write (iout,*) "Arrays UG and UGDER"
2891         do i=1,nres-1
2892           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2893      &     ((ug(l,k,i),l=1,2),k=1,2),
2894      &     ((ugder(l,k,i),l=1,2),k=1,2)
2895         enddo
2896         write (iout,*) "Arrays UG2 and UG2DER"
2897         do i=1,nres-1
2898           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2899      &     ((ug2(l,k,i),l=1,2),k=1,2),
2900      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2901         enddo
2902         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2903         do i=1,nres-1
2904           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2905      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2906      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2907         enddo
2908         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2909         do i=1,nres-1
2910           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2911      &     costab(i),sintab(i),costab2(i),sintab2(i)
2912         enddo
2913         write (iout,*) "Array MUDER"
2914         do i=1,nres-1
2915           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2916         enddo
2917 c      endif
2918 #endif
2919 #endif
2920 cd      do i=1,nres
2921 cd        iti = itortyp(itype(i))
2922 cd        write (iout,*) i
2923 cd        do j=1,2
2924 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2925 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2926 cd        enddo
2927 cd      enddo
2928       return
2929       end
2930 C--------------------------------------------------------------------------
2931       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2932 C
2933 C This subroutine calculates the average interaction energy and its gradient
2934 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2935 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2936 C The potential depends both on the distance of peptide-group centers and on
2937 C the orientation of the CA-CA virtual bonds.
2938 C
2939       implicit real*8 (a-h,o-z)
2940 #ifdef MPI
2941       include 'mpif.h'
2942 #endif
2943       include 'DIMENSIONS'
2944       include 'COMMON.CONTROL'
2945       include 'COMMON.SETUP'
2946       include 'COMMON.IOUNITS'
2947       include 'COMMON.GEO'
2948       include 'COMMON.VAR'
2949       include 'COMMON.LOCAL'
2950       include 'COMMON.CHAIN'
2951       include 'COMMON.DERIV'
2952       include 'COMMON.INTERACT'
2953       include 'COMMON.CONTACTS'
2954       include 'COMMON.TORSION'
2955       include 'COMMON.VECTORS'
2956       include 'COMMON.FFIELD'
2957       include 'COMMON.TIME1'
2958       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2959      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2960       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2961      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2962       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2963      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2964      &    num_conti,j1,j2
2965 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2966 #ifdef MOMENT
2967       double precision scal_el /1.0d0/
2968 #else
2969       double precision scal_el /0.5d0/
2970 #endif
2971 C 12/13/98
2972 C 13-go grudnia roku pamietnego...
2973       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2974      &                   0.0d0,1.0d0,0.0d0,
2975      &                   0.0d0,0.0d0,1.0d0/
2976 cd      write(iout,*) 'In EELEC'
2977 cd      do i=1,nloctyp
2978 cd        write(iout,*) 'Type',i
2979 cd        write(iout,*) 'B1',B1(:,i)
2980 cd        write(iout,*) 'B2',B2(:,i)
2981 cd        write(iout,*) 'CC',CC(:,:,i)
2982 cd        write(iout,*) 'DD',DD(:,:,i)
2983 cd        write(iout,*) 'EE',EE(:,:,i)
2984 cd      enddo
2985 cd      call check_vecgrad
2986 cd      stop
2987       if (icheckgrad.eq.1) then
2988         do i=1,nres-1
2989           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2990           do k=1,3
2991             dc_norm(k,i)=dc(k,i)*fac
2992           enddo
2993 c          write (iout,*) 'i',i,' fac',fac
2994         enddo
2995       endif
2996       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2997      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2998      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2999 c        call vec_and_deriv
3000 #ifdef TIMING
3001         time01=MPI_Wtime()
3002 #endif
3003         call set_matrices
3004 #ifdef TIMING
3005         time_mat=time_mat+MPI_Wtime()-time01
3006 #endif
3007       endif
3008 cd      do i=1,nres-1
3009 cd        write (iout,*) 'i=',i
3010 cd        do k=1,3
3011 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3012 cd        enddo
3013 cd        do k=1,3
3014 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3015 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3016 cd        enddo
3017 cd      enddo
3018       t_eelecij=0.0d0
3019       ees=0.0D0
3020       evdw1=0.0D0
3021       eel_loc=0.0d0
3022       eello_turn3=0.0d0
3023       eello_turn4=0.0d0
3024       ind=0
3025       do i=1,nres
3026         num_cont_hb(i)=0
3027       enddo
3028 cd      print '(a)','Enter EELEC'
3029 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3030       do i=1,nres
3031         gel_loc_loc(i)=0.0d0
3032         gcorr_loc(i)=0.0d0
3033       enddo
3034 c
3035 c
3036 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3037 C
3038 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3039 C
3040       do i=iturn3_start,iturn3_end
3041         dxi=dc(1,i)
3042         dyi=dc(2,i)
3043         dzi=dc(3,i)
3044         dx_normi=dc_norm(1,i)
3045         dy_normi=dc_norm(2,i)
3046         dz_normi=dc_norm(3,i)
3047         xmedi=c(1,i)+0.5d0*dxi
3048         ymedi=c(2,i)+0.5d0*dyi
3049         zmedi=c(3,i)+0.5d0*dzi
3050         num_conti=0
3051         call eelecij(i,i+2,ees,evdw1,eel_loc)
3052         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3053         num_cont_hb(i)=num_conti
3054       enddo
3055       do i=iturn4_start,iturn4_end
3056         dxi=dc(1,i)
3057         dyi=dc(2,i)
3058         dzi=dc(3,i)
3059         dx_normi=dc_norm(1,i)
3060         dy_normi=dc_norm(2,i)
3061         dz_normi=dc_norm(3,i)
3062         xmedi=c(1,i)+0.5d0*dxi
3063         ymedi=c(2,i)+0.5d0*dyi
3064         zmedi=c(3,i)+0.5d0*dzi
3065         num_conti=num_cont_hb(i)
3066         call eelecij(i,i+3,ees,evdw1,eel_loc)
3067         if (wturn4.gt.0.0d0) call eturn4(i,eello_turn4)
3068         num_cont_hb(i)=num_conti
3069       enddo   ! i
3070 c
3071 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3072 c
3073       do i=iatel_s,iatel_e
3074         dxi=dc(1,i)
3075         dyi=dc(2,i)
3076         dzi=dc(3,i)
3077         dx_normi=dc_norm(1,i)
3078         dy_normi=dc_norm(2,i)
3079         dz_normi=dc_norm(3,i)
3080         xmedi=c(1,i)+0.5d0*dxi
3081         ymedi=c(2,i)+0.5d0*dyi
3082         zmedi=c(3,i)+0.5d0*dzi
3083 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3084         num_conti=num_cont_hb(i)
3085         do j=ielstart(i),ielend(i)
3086           call eelecij(i,j,ees,evdw1,eel_loc)
3087         enddo ! j
3088         num_cont_hb(i)=num_conti
3089       enddo   ! i
3090 c      write (iout,*) "Number of loop steps in EELEC:",ind
3091 cd      do i=1,nres
3092 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3093 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3094 cd      enddo
3095 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3096 ccc      eel_loc=eel_loc+eello_turn3
3097 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3098       return
3099       end
3100 C-------------------------------------------------------------------------------
3101       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3102       implicit real*8 (a-h,o-z)
3103       include 'DIMENSIONS'
3104 #ifdef MPI
3105       include "mpif.h"
3106 #endif
3107       include 'COMMON.CONTROL'
3108       include 'COMMON.IOUNITS'
3109       include 'COMMON.GEO'
3110       include 'COMMON.VAR'
3111       include 'COMMON.LOCAL'
3112       include 'COMMON.CHAIN'
3113       include 'COMMON.DERIV'
3114       include 'COMMON.INTERACT'
3115       include 'COMMON.CONTACTS'
3116       include 'COMMON.TORSION'
3117       include 'COMMON.VECTORS'
3118       include 'COMMON.FFIELD'
3119       include 'COMMON.TIME1'
3120       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3121      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3122       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3123      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
3124       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3125      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3126      &    num_conti,j1,j2
3127 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3128 #ifdef MOMENT
3129       double precision scal_el /1.0d0/
3130 #else
3131       double precision scal_el /0.5d0/
3132 #endif
3133 C 12/13/98
3134 C 13-go grudnia roku pamietnego...
3135       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3136      &                   0.0d0,1.0d0,0.0d0,
3137      &                   0.0d0,0.0d0,1.0d0/
3138 c          time00=MPI_Wtime()
3139 cd      write (iout,*) "eelecij",i,j
3140 c          ind=ind+1
3141           iteli=itel(i)
3142           itelj=itel(j)
3143           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3144           aaa=app(iteli,itelj)
3145           bbb=bpp(iteli,itelj)
3146           ael6i=ael6(iteli,itelj)
3147           ael3i=ael3(iteli,itelj)
3148           dxj=dc(1,j)
3149           dyj=dc(2,j)
3150           dzj=dc(3,j)
3151           dx_normj=dc_norm(1,j)
3152           dy_normj=dc_norm(2,j)
3153           dz_normj=dc_norm(3,j)
3154           xj=c(1,j)+0.5D0*dxj-xmedi
3155           yj=c(2,j)+0.5D0*dyj-ymedi
3156           zj=c(3,j)+0.5D0*dzj-zmedi
3157           rij=xj*xj+yj*yj+zj*zj
3158           rrmij=1.0D0/rij
3159           rij=dsqrt(rij)
3160           rmij=1.0D0/rij
3161           r3ij=rrmij*rmij
3162           r6ij=r3ij*r3ij
3163           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3164           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3165           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3166           fac=cosa-3.0D0*cosb*cosg
3167           ev1=aaa*r6ij*r6ij
3168 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3169           if (j.eq.i+2) ev1=scal_el*ev1
3170           ev2=bbb*r6ij
3171           fac3=ael6i*r6ij
3172           fac4=ael3i*r3ij
3173           evdwij=ev1+ev2
3174           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3175           el2=fac4*fac
3176           eesij=el1+el2
3177 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3178           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3179           ees=ees+eesij
3180           evdw1=evdw1+evdwij
3181 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3182 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3183 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3184 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3185
3186           if (energy_dec) then
3187               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3188               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3189           endif
3190
3191 C
3192 C Calculate contributions to the Cartesian gradient.
3193 C
3194 #ifdef SPLITELE
3195           facvdw=-6*rrmij*(ev1+evdwij)
3196           facel=-3*rrmij*(el1+eesij)
3197           fac1=fac
3198           erij(1)=xj*rmij
3199           erij(2)=yj*rmij
3200           erij(3)=zj*rmij
3201 *
3202 * Radial derivatives. First process both termini of the fragment (i,j)
3203 *
3204           ggg(1)=facel*xj
3205           ggg(2)=facel*yj
3206           ggg(3)=facel*zj
3207 c          do k=1,3
3208 c            ghalf=0.5D0*ggg(k)
3209 c            gelc(k,i)=gelc(k,i)+ghalf
3210 c            gelc(k,j)=gelc(k,j)+ghalf
3211 c          enddo
3212 c 9/28/08 AL Gradient compotents will be summed only at the end
3213           do k=1,3
3214             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3215             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3216           enddo
3217 *
3218 * Loop over residues i+1 thru j-1.
3219 *
3220 cgrad          do k=i+1,j-1
3221 cgrad            do l=1,3
3222 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3223 cgrad            enddo
3224 cgrad          enddo
3225           ggg(1)=facvdw*xj
3226           ggg(2)=facvdw*yj
3227           ggg(3)=facvdw*zj
3228 c          do k=1,3
3229 c            ghalf=0.5D0*ggg(k)
3230 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3231 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3232 c          enddo
3233 c 9/28/08 AL Gradient compotents will be summed only at the end
3234           do k=1,3
3235             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3236             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3237           enddo
3238 *
3239 * Loop over residues i+1 thru j-1.
3240 *
3241 cgrad          do k=i+1,j-1
3242 cgrad            do l=1,3
3243 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3244 cgrad            enddo
3245 cgrad          enddo
3246 #else
3247           facvdw=ev1+evdwij
3248           facel=el1+eesij
3249           fac1=fac
3250           fac=-3*rrmij*(facvdw+facvdw+facel)
3251           erij(1)=xj*rmij
3252           erij(2)=yj*rmij
3253           erij(3)=zj*rmij
3254 *
3255 * Radial derivatives. First process both termini of the fragment (i,j)
3256 *
3257           ggg(1)=fac*xj
3258           ggg(2)=fac*yj
3259           ggg(3)=fac*zj
3260 c          do k=1,3
3261 c            ghalf=0.5D0*ggg(k)
3262 c            gelc(k,i)=gelc(k,i)+ghalf
3263 c            gelc(k,j)=gelc(k,j)+ghalf
3264 c          enddo
3265 c 9/28/08 AL Gradient compotents will be summed only at the end
3266           do k=1,3
3267             gelc_long(k,j)=gelc(k,j)+ggg(k)
3268             gelc_long(k,i)=gelc(k,i)-ggg(k)
3269           enddo
3270 *
3271 * Loop over residues i+1 thru j-1.
3272 *
3273 cgrad          do k=i+1,j-1
3274 cgrad            do l=1,3
3275 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3276 cgrad            enddo
3277 cgrad          enddo
3278 c 9/28/08 AL Gradient compotents will be summed only at the end
3279           ggg(1)=facvdw*xj
3280           ggg(2)=facvdw*yj
3281           ggg(3)=facvdw*zj
3282           do k=1,3
3283             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3284             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3285           enddo
3286 #endif
3287 *
3288 * Angular part
3289 *
3290           ecosa=2.0D0*fac3*fac1+fac4
3291           fac4=-3.0D0*fac4
3292           fac3=-6.0D0*fac3
3293           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3294           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3295           do k=1,3
3296             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3297             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3298           enddo
3299 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3300 cd   &          (dcosg(k),k=1,3)
3301           do k=1,3
3302             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3303           enddo
3304 c          do k=1,3
3305 c            ghalf=0.5D0*ggg(k)
3306 c            gelc(k,i)=gelc(k,i)+ghalf
3307 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3308 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3309 c            gelc(k,j)=gelc(k,j)+ghalf
3310 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3311 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3312 c          enddo
3313 cgrad          do k=i+1,j-1
3314 cgrad            do l=1,3
3315 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3316 cgrad            enddo
3317 cgrad          enddo
3318           do k=1,3
3319             gelc(k,i)=gelc(k,i)
3320      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3321      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3322             gelc(k,j)=gelc(k,j)
3323      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3324      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3325             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3326             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3327           enddo
3328           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3329      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3330      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3331 C
3332 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3333 C   energy of a peptide unit is assumed in the form of a second-order
3334 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3335 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3336 C   are computed for EVERY pair of non-contiguous peptide groups.
3337 C
3338           if (j.lt.nres-1) then
3339             j1=j+1
3340             j2=j-1
3341           else
3342             j1=j-1
3343             j2=j-2
3344           endif
3345           kkk=0
3346           do k=1,2
3347             do l=1,2
3348               kkk=kkk+1
3349               muij(kkk)=mu(k,i)*mu(l,j)
3350             enddo
3351           enddo
3352 cd         write (iout,*) 'EELEC: i',i,' j',j
3353 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3354 cd          write(iout,*) 'muij',muij
3355           ury=scalar(uy(1,i),erij)
3356           urz=scalar(uz(1,i),erij)
3357           vry=scalar(uy(1,j),erij)
3358           vrz=scalar(uz(1,j),erij)
3359           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3360           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3361           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3362           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3363           fac=dsqrt(-ael6i)*r3ij
3364           a22=a22*fac
3365           a23=a23*fac
3366           a32=a32*fac
3367           a33=a33*fac
3368 cd          write (iout,'(4i5,4f10.5)')
3369 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3370 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3371 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3372 cd     &      uy(:,j),uz(:,j)
3373 cd          write (iout,'(4f10.5)')
3374 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3375 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3376 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3377 cd           write (iout,'(9f10.5/)')
3378 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3379 C Derivatives of the elements of A in virtual-bond vectors
3380           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3381           do k=1,3
3382             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3383             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3384             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3385             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3386             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3387             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3388             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3389             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3390             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3391             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3392             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3393             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3394           enddo
3395 C Compute radial contributions to the gradient
3396           facr=-3.0d0*rrmij
3397           a22der=a22*facr
3398           a23der=a23*facr
3399           a32der=a32*facr
3400           a33der=a33*facr
3401           agg(1,1)=a22der*xj
3402           agg(2,1)=a22der*yj
3403           agg(3,1)=a22der*zj
3404           agg(1,2)=a23der*xj
3405           agg(2,2)=a23der*yj
3406           agg(3,2)=a23der*zj
3407           agg(1,3)=a32der*xj
3408           agg(2,3)=a32der*yj
3409           agg(3,3)=a32der*zj
3410           agg(1,4)=a33der*xj
3411           agg(2,4)=a33der*yj
3412           agg(3,4)=a33der*zj
3413 C Add the contributions coming from er
3414           fac3=-3.0d0*fac
3415           do k=1,3
3416             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3417             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3418             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3419             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3420           enddo
3421           do k=1,3
3422 C Derivatives in DC(i)
3423 cgrad            ghalf1=0.5d0*agg(k,1)
3424 cgrad            ghalf2=0.5d0*agg(k,2)
3425 cgrad            ghalf3=0.5d0*agg(k,3)
3426 cgrad            ghalf4=0.5d0*agg(k,4)
3427             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3428      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3429             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3430      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3431             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3432      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3433             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3434      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3435 C Derivatives in DC(i+1)
3436             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3437      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3438             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3439      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3440             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3441      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3442             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3443      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3444 C Derivatives in DC(j)
3445             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3446      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3447             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3448      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3449             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3450      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3451             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3452      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3453 C Derivatives in DC(j+1) or DC(nres-1)
3454             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3455      &      -3.0d0*vryg(k,3)*ury)
3456             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3457      &      -3.0d0*vrzg(k,3)*ury)
3458             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3459      &      -3.0d0*vryg(k,3)*urz)
3460             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3461      &      -3.0d0*vrzg(k,3)*urz)
3462 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3463 cgrad              do l=1,4
3464 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3465 cgrad              enddo
3466 cgrad            endif
3467           enddo
3468           acipa(1,1)=a22
3469           acipa(1,2)=a23
3470           acipa(2,1)=a32
3471           acipa(2,2)=a33
3472           a22=-a22
3473           a23=-a23
3474           do l=1,2
3475             do k=1,3
3476               agg(k,l)=-agg(k,l)
3477               aggi(k,l)=-aggi(k,l)
3478               aggi1(k,l)=-aggi1(k,l)
3479               aggj(k,l)=-aggj(k,l)
3480               aggj1(k,l)=-aggj1(k,l)
3481             enddo
3482           enddo
3483           if (j.lt.nres-1) then
3484             a22=-a22
3485             a32=-a32
3486             do l=1,3,2
3487               do k=1,3
3488                 agg(k,l)=-agg(k,l)
3489                 aggi(k,l)=-aggi(k,l)
3490                 aggi1(k,l)=-aggi1(k,l)
3491                 aggj(k,l)=-aggj(k,l)
3492                 aggj1(k,l)=-aggj1(k,l)
3493               enddo
3494             enddo
3495           else
3496             a22=-a22
3497             a23=-a23
3498             a32=-a32
3499             a33=-a33
3500             do l=1,4
3501               do k=1,3
3502                 agg(k,l)=-agg(k,l)
3503                 aggi(k,l)=-aggi(k,l)
3504                 aggi1(k,l)=-aggi1(k,l)
3505                 aggj(k,l)=-aggj(k,l)
3506                 aggj1(k,l)=-aggj1(k,l)
3507               enddo
3508             enddo
3509           endif
3510           ENDIF ! WCORR
3511           IF (wel_loc.gt.0.0d0) THEN
3512 C Contribution to the local-electrostatic energy coming from the i-j pair
3513           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3514      &     +a33*muij(4)
3515 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3516
3517           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3518      &            'eelloc',i,j,eel_loc_ij
3519
3520           eel_loc=eel_loc+eel_loc_ij
3521 C Partial derivatives in virtual-bond dihedral angles gamma
3522           if (i.gt.1)
3523      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3524      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3525      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3526           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3527      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3528      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3529 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3530           do l=1,3
3531             ggg(l)=agg(l,1)*muij(1)+
3532      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3533             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3534             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3535 cgrad            ghalf=0.5d0*ggg(l)
3536 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3537 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3538           enddo
3539 cgrad          do k=i+1,j2
3540 cgrad            do l=1,3
3541 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3542 cgrad            enddo
3543 cgrad          enddo
3544 C Remaining derivatives of eello
3545           do l=1,3
3546             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3547      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3548             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3549      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3550             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3551      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3552             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3553      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3554           enddo
3555           ENDIF
3556 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3557 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3558           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3559      &       .and. num_conti.le.maxconts) then
3560 c            write (iout,*) i,j," entered corr"
3561 C
3562 C Calculate the contact function. The ith column of the array JCONT will
3563 C contain the numbers of atoms that make contacts with the atom I (of numbers
3564 C greater than I). The arrays FACONT and GACONT will contain the values of
3565 C the contact function and its derivative.
3566 c           r0ij=1.02D0*rpp(iteli,itelj)
3567 c           r0ij=1.11D0*rpp(iteli,itelj)
3568             r0ij=2.20D0*rpp(iteli,itelj)
3569 c           r0ij=1.55D0*rpp(iteli,itelj)
3570             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3571             if (fcont.gt.0.0D0) then
3572               num_conti=num_conti+1
3573               if (num_conti.gt.maxconts) then
3574                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3575      &                         ' will skip next contacts for this conf.'
3576               else
3577                 jcont_hb(num_conti,i)=j
3578 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3579 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3580                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3581      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3582 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3583 C  terms.
3584                 d_cont(num_conti,i)=rij
3585 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3586 C     --- Electrostatic-interaction matrix ---
3587                 a_chuj(1,1,num_conti,i)=a22
3588                 a_chuj(1,2,num_conti,i)=a23
3589                 a_chuj(2,1,num_conti,i)=a32
3590                 a_chuj(2,2,num_conti,i)=a33
3591 C     --- Gradient of rij
3592                 do kkk=1,3
3593                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3594                 enddo
3595                 kkll=0
3596                 do k=1,2
3597                   do l=1,2
3598                     kkll=kkll+1
3599                     do m=1,3
3600                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3601                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3602                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3603                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3604                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3605                     enddo
3606                   enddo
3607                 enddo
3608                 ENDIF
3609                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3610 C Calculate contact energies
3611                 cosa4=4.0D0*cosa
3612                 wij=cosa-3.0D0*cosb*cosg
3613                 cosbg1=cosb+cosg
3614                 cosbg2=cosb-cosg
3615 c               fac3=dsqrt(-ael6i)/r0ij**3
3616                 fac3=dsqrt(-ael6i)*r3ij
3617 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3618                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3619                 if (ees0tmp.gt.0) then
3620                   ees0pij=dsqrt(ees0tmp)
3621                 else
3622                   ees0pij=0
3623                 endif
3624 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3625                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3626                 if (ees0tmp.gt.0) then
3627                   ees0mij=dsqrt(ees0tmp)
3628                 else
3629                   ees0mij=0
3630                 endif
3631 c               ees0mij=0.0D0
3632                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3633                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3634 C Diagnostics. Comment out or remove after debugging!
3635 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3636 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3637 c               ees0m(num_conti,i)=0.0D0
3638 C End diagnostics.
3639 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3640 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3641 C Angular derivatives of the contact function
3642                 ees0pij1=fac3/ees0pij
3643                 ees0mij1=fac3/ees0mij
3644                 fac3p=-3.0D0*fac3*rrmij
3645                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3646                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3647 c               ees0mij1=0.0D0
3648                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3649                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3650                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3651                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3652                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3653                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3654                 ecosap=ecosa1+ecosa2
3655                 ecosbp=ecosb1+ecosb2
3656                 ecosgp=ecosg1+ecosg2
3657                 ecosam=ecosa1-ecosa2
3658                 ecosbm=ecosb1-ecosb2
3659                 ecosgm=ecosg1-ecosg2
3660 C Diagnostics
3661 c               ecosap=ecosa1
3662 c               ecosbp=ecosb1
3663 c               ecosgp=ecosg1
3664 c               ecosam=0.0D0
3665 c               ecosbm=0.0D0
3666 c               ecosgm=0.0D0
3667 C End diagnostics
3668                 facont_hb(num_conti,i)=fcont
3669                 fprimcont=fprimcont/rij
3670 cd              facont_hb(num_conti,i)=1.0D0
3671 C Following line is for diagnostics.
3672 cd              fprimcont=0.0D0
3673                 do k=1,3
3674                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3675                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3676                 enddo
3677                 do k=1,3
3678                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3679                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3680                 enddo
3681                 gggp(1)=gggp(1)+ees0pijp*xj
3682                 gggp(2)=gggp(2)+ees0pijp*yj
3683                 gggp(3)=gggp(3)+ees0pijp*zj
3684                 gggm(1)=gggm(1)+ees0mijp*xj
3685                 gggm(2)=gggm(2)+ees0mijp*yj
3686                 gggm(3)=gggm(3)+ees0mijp*zj
3687 C Derivatives due to the contact function
3688                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3689                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3690                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3691                 do k=1,3
3692 c
3693 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3694 c          following the change of gradient-summation algorithm.
3695 c
3696 cgrad                  ghalfp=0.5D0*gggp(k)
3697 cgrad                  ghalfm=0.5D0*gggm(k)
3698                   gacontp_hb1(k,num_conti,i)=!ghalfp
3699      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3700      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3701                   gacontp_hb2(k,num_conti,i)=!ghalfp
3702      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3703      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3704                   gacontp_hb3(k,num_conti,i)=gggp(k)
3705                   gacontm_hb1(k,num_conti,i)=!ghalfm
3706      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3707      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3708                   gacontm_hb2(k,num_conti,i)=!ghalfm
3709      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3710      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3711                   gacontm_hb3(k,num_conti,i)=gggm(k)
3712                 enddo
3713 C Diagnostics. Comment out or remove after debugging!
3714 cdiag           do k=1,3
3715 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3716 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3717 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3718 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3719 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3720 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3721 cdiag           enddo
3722               ENDIF ! wcorr
3723               endif  ! num_conti.le.maxconts
3724             endif  ! fcont.gt.0
3725           endif    ! j.gt.i+1
3726           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3727             do k=1,4
3728               do l=1,3
3729                 ghalf=0.5d0*agg(l,k)
3730                 aggi(l,k)=aggi(l,k)+ghalf
3731                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3732                 aggj(l,k)=aggj(l,k)+ghalf
3733               enddo
3734             enddo
3735             if (j.eq.nres-1 .and. i.lt.j-2) then
3736               do k=1,4
3737                 do l=1,3
3738                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3739                 enddo
3740               enddo
3741             endif
3742           endif
3743 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3744       return
3745       end
3746 C-----------------------------------------------------------------------------
3747       subroutine eturn3(i,eello_turn3)
3748 C Third- and fourth-order contributions from turns
3749       implicit real*8 (a-h,o-z)
3750       include 'DIMENSIONS'
3751       include 'COMMON.IOUNITS'
3752       include 'COMMON.GEO'
3753       include 'COMMON.VAR'
3754       include 'COMMON.LOCAL'
3755       include 'COMMON.CHAIN'
3756       include 'COMMON.DERIV'
3757       include 'COMMON.INTERACT'
3758       include 'COMMON.CONTACTS'
3759       include 'COMMON.TORSION'
3760       include 'COMMON.VECTORS'
3761       include 'COMMON.FFIELD'
3762       include 'COMMON.CONTROL'
3763       dimension ggg(3)
3764       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3765      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3766      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3767       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3768      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3769       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3770      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3771      &    num_conti,j1,j2
3772       j=i+2
3773 c      write (iout,*) "eturn3",i,j,j1,j2
3774       a_temp(1,1)=a22
3775       a_temp(1,2)=a23
3776       a_temp(2,1)=a32
3777       a_temp(2,2)=a33
3778 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3779 C
3780 C               Third-order contributions
3781 C
3782 C                 (i+2)o----(i+3)
3783 C                      | |
3784 C                      | |
3785 C                 (i+1)o----i
3786 C
3787 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3788 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3789         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3790         call transpose2(auxmat(1,1),auxmat1(1,1))
3791         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3792         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3793         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3794      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3795 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3796 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3797 cd     &    ' eello_turn3_num',4*eello_turn3_num
3798 C Derivatives in gamma(i)
3799         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3800         call transpose2(auxmat2(1,1),auxmat3(1,1))
3801         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3802         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3803 C Derivatives in gamma(i+1)
3804         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3805         call transpose2(auxmat2(1,1),auxmat3(1,1))
3806         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3807         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3808      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3809 C Cartesian derivatives
3810         do l=1,3
3811 c            ghalf1=0.5d0*agg(l,1)
3812 c            ghalf2=0.5d0*agg(l,2)
3813 c            ghalf3=0.5d0*agg(l,3)
3814 c            ghalf4=0.5d0*agg(l,4)
3815           a_temp(1,1)=aggi(l,1)!+ghalf1
3816           a_temp(1,2)=aggi(l,2)!+ghalf2
3817           a_temp(2,1)=aggi(l,3)!+ghalf3
3818           a_temp(2,2)=aggi(l,4)!+ghalf4
3819           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3820           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3821      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3822           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3823           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3824           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3825           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3826           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3827           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3828      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3829           a_temp(1,1)=aggj(l,1)!+ghalf1
3830           a_temp(1,2)=aggj(l,2)!+ghalf2
3831           a_temp(2,1)=aggj(l,3)!+ghalf3
3832           a_temp(2,2)=aggj(l,4)!+ghalf4
3833           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3834           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3835      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3836           a_temp(1,1)=aggj1(l,1)
3837           a_temp(1,2)=aggj1(l,2)
3838           a_temp(2,1)=aggj1(l,3)
3839           a_temp(2,2)=aggj1(l,4)
3840           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3841           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3842      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3843         enddo
3844       return
3845       end
3846 C-------------------------------------------------------------------------------
3847       subroutine eturn4(i,eello_turn4)
3848 C Third- and fourth-order contributions from turns
3849       implicit real*8 (a-h,o-z)
3850       include 'DIMENSIONS'
3851       include 'COMMON.IOUNITS'
3852       include 'COMMON.GEO'
3853       include 'COMMON.VAR'
3854       include 'COMMON.LOCAL'
3855       include 'COMMON.CHAIN'
3856       include 'COMMON.DERIV'
3857       include 'COMMON.INTERACT'
3858       include 'COMMON.CONTACTS'
3859       include 'COMMON.TORSION'
3860       include 'COMMON.VECTORS'
3861       include 'COMMON.FFIELD'
3862       include 'COMMON.CONTROL'
3863       dimension ggg(3)
3864       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3865      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3866      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3867       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3868      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3869       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3870      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3871      &    num_conti,j1,j2
3872       j=i+3
3873 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3874 C
3875 C               Fourth-order contributions
3876 C
3877 C                 (i+3)o----(i+4)
3878 C                     /  |
3879 C               (i+2)o   |
3880 C                     \  |
3881 C                 (i+1)o----i
3882 C
3883 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3884 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3885 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3886         a_temp(1,1)=a22
3887         a_temp(1,2)=a23
3888         a_temp(2,1)=a32
3889         a_temp(2,2)=a33
3890         iti1=itortyp(itype(i+1))
3891         iti2=itortyp(itype(i+2))
3892         iti3=itortyp(itype(i+3))
3893 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3894         call transpose2(EUg(1,1,i+1),e1t(1,1))
3895         call transpose2(Eug(1,1,i+2),e2t(1,1))
3896         call transpose2(Eug(1,1,i+3),e3t(1,1))
3897         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3898         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3899         s1=scalar2(b1(1,iti2),auxvec(1))
3900         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3901         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3902         s2=scalar2(b1(1,iti1),auxvec(1))
3903         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3904         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3905         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3906         eello_turn4=eello_turn4-(s1+s2+s3)
3907         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3908      &      'eturn4',i,j,-(s1+s2+s3)
3909 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3910 cd     &    ' eello_turn4_num',8*eello_turn4_num
3911 C Derivatives in gamma(i)
3912         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3913         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3914         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3915         s1=scalar2(b1(1,iti2),auxvec(1))
3916         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3917         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3918         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3919 C Derivatives in gamma(i+1)
3920         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3921         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3922         s2=scalar2(b1(1,iti1),auxvec(1))
3923         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3924         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3925         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3926         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3927 C Derivatives in gamma(i+2)
3928         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3929         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3930         s1=scalar2(b1(1,iti2),auxvec(1))
3931         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3932         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3933         s2=scalar2(b1(1,iti1),auxvec(1))
3934         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3935         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3936         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3937         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3938 C Cartesian derivatives
3939 C Derivatives of this turn contributions in DC(i+2)
3940         if (j.lt.nres-1) then
3941           do l=1,3
3942             a_temp(1,1)=agg(l,1)
3943             a_temp(1,2)=agg(l,2)
3944             a_temp(2,1)=agg(l,3)
3945             a_temp(2,2)=agg(l,4)
3946             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3947             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3948             s1=scalar2(b1(1,iti2),auxvec(1))
3949             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3950             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3951             s2=scalar2(b1(1,iti1),auxvec(1))
3952             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3953             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3954             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3955             ggg(l)=-(s1+s2+s3)
3956             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3957           enddo
3958         endif
3959 C Remaining derivatives of this turn contribution
3960         do l=1,3
3961           a_temp(1,1)=aggi(l,1)
3962           a_temp(1,2)=aggi(l,2)
3963           a_temp(2,1)=aggi(l,3)
3964           a_temp(2,2)=aggi(l,4)
3965           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3966           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3967           s1=scalar2(b1(1,iti2),auxvec(1))
3968           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3969           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3970           s2=scalar2(b1(1,iti1),auxvec(1))
3971           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3972           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3973           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3974           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3975           a_temp(1,1)=aggi1(l,1)
3976           a_temp(1,2)=aggi1(l,2)
3977           a_temp(2,1)=aggi1(l,3)
3978           a_temp(2,2)=aggi1(l,4)
3979           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3980           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3981           s1=scalar2(b1(1,iti2),auxvec(1))
3982           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3983           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3984           s2=scalar2(b1(1,iti1),auxvec(1))
3985           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3986           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3987           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3988           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3989           a_temp(1,1)=aggj(l,1)
3990           a_temp(1,2)=aggj(l,2)
3991           a_temp(2,1)=aggj(l,3)
3992           a_temp(2,2)=aggj(l,4)
3993           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3994           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3995           s1=scalar2(b1(1,iti2),auxvec(1))
3996           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3997           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3998           s2=scalar2(b1(1,iti1),auxvec(1))
3999           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4000           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4001           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4002           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
4003           a_temp(1,1)=aggj1(l,1)
4004           a_temp(1,2)=aggj1(l,2)
4005           a_temp(2,1)=aggj1(l,3)
4006           a_temp(2,2)=aggj1(l,4)
4007           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4008           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4009           s1=scalar2(b1(1,iti2),auxvec(1))
4010           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4011           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4012           s2=scalar2(b1(1,iti1),auxvec(1))
4013           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4014           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4015           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4016 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4017           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
4018         enddo
4019       return
4020       end
4021 C-----------------------------------------------------------------------------
4022       subroutine vecpr(u,v,w)
4023       implicit real*8(a-h,o-z)
4024       dimension u(3),v(3),w(3)
4025       w(1)=u(2)*v(3)-u(3)*v(2)
4026       w(2)=-u(1)*v(3)+u(3)*v(1)
4027       w(3)=u(1)*v(2)-u(2)*v(1)
4028       return
4029       end
4030 C-----------------------------------------------------------------------------
4031       subroutine unormderiv(u,ugrad,unorm,ungrad)
4032 C This subroutine computes the derivatives of a normalized vector u, given
4033 C the derivatives computed without normalization conditions, ugrad. Returns
4034 C ungrad.
4035       implicit none
4036       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
4037       double precision vec(3)
4038       double precision scalar
4039       integer i,j
4040 c      write (2,*) 'ugrad',ugrad
4041 c      write (2,*) 'u',u
4042       do i=1,3
4043         vec(i)=scalar(ugrad(1,i),u(1))
4044       enddo
4045 c      write (2,*) 'vec',vec
4046       do i=1,3
4047         do j=1,3
4048           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4049         enddo
4050       enddo
4051 c      write (2,*) 'ungrad',ungrad
4052       return
4053       end
4054 C-----------------------------------------------------------------------------
4055       subroutine escp_soft_sphere(evdw2,evdw2_14)
4056 C
4057 C This subroutine calculates the excluded-volume interaction energy between
4058 C peptide-group centers and side chains and its gradient in virtual-bond and
4059 C side-chain vectors.
4060 C
4061       implicit real*8 (a-h,o-z)
4062       include 'DIMENSIONS'
4063       include 'COMMON.GEO'
4064       include 'COMMON.VAR'
4065       include 'COMMON.LOCAL'
4066       include 'COMMON.CHAIN'
4067       include 'COMMON.DERIV'
4068       include 'COMMON.INTERACT'
4069       include 'COMMON.FFIELD'
4070       include 'COMMON.IOUNITS'
4071       include 'COMMON.CONTROL'
4072       dimension ggg(3)
4073       evdw2=0.0D0
4074       evdw2_14=0.0d0
4075       r0_scp=4.5d0
4076 cd    print '(a)','Enter ESCP'
4077 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4078       do i=iatscp_s,iatscp_e
4079         iteli=itel(i)
4080         xi=0.5D0*(c(1,i)+c(1,i+1))
4081         yi=0.5D0*(c(2,i)+c(2,i+1))
4082         zi=0.5D0*(c(3,i)+c(3,i+1))
4083
4084         do iint=1,nscp_gr(i)
4085
4086         do j=iscpstart(i,iint),iscpend(i,iint)
4087           itypj=itype(j)
4088 C Uncomment following three lines for SC-p interactions
4089 c         xj=c(1,nres+j)-xi
4090 c         yj=c(2,nres+j)-yi
4091 c         zj=c(3,nres+j)-zi
4092 C Uncomment following three lines for Ca-p interactions
4093           xj=c(1,j)-xi
4094           yj=c(2,j)-yi
4095           zj=c(3,j)-zi
4096           rij=xj*xj+yj*yj+zj*zj
4097           r0ij=r0_scp
4098           r0ijsq=r0ij*r0ij
4099           if (rij.lt.r0ijsq) then
4100             evdwij=0.25d0*(rij-r0ijsq)**2
4101             fac=rij-r0ijsq
4102           else
4103             evdwij=0.0d0
4104             fac=0.0d0
4105           endif
4106           evdw2=evdw2+evdwij
4107 C
4108 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4109 C
4110           ggg(1)=xj*fac
4111           ggg(2)=yj*fac
4112           ggg(3)=zj*fac
4113 cgrad          if (j.lt.i) then
4114 cd          write (iout,*) 'j<i'
4115 C Uncomment following three lines for SC-p interactions
4116 c           do k=1,3
4117 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4118 c           enddo
4119 cgrad          else
4120 cd          write (iout,*) 'j>i'
4121 cgrad            do k=1,3
4122 cgrad              ggg(k)=-ggg(k)
4123 C Uncomment following line for SC-p interactions
4124 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4125 cgrad            enddo
4126 cgrad          endif
4127 cgrad          do k=1,3
4128 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4129 cgrad          enddo
4130 cgrad          kstart=min0(i+1,j)
4131 cgrad          kend=max0(i-1,j-1)
4132 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4133 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4134 cgrad          do k=kstart,kend
4135 cgrad            do l=1,3
4136 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4137 cgrad            enddo
4138 cgrad          enddo
4139           do k=1,3
4140             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4141             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4142           enddo
4143         enddo
4144
4145         enddo ! iint
4146       enddo ! i
4147       return
4148       end
4149 C-----------------------------------------------------------------------------
4150       subroutine escp(evdw2,evdw2_14)
4151 C
4152 C This subroutine calculates the excluded-volume interaction energy between
4153 C peptide-group centers and side chains and its gradient in virtual-bond and
4154 C side-chain vectors.
4155 C
4156       implicit real*8 (a-h,o-z)
4157       include 'DIMENSIONS'
4158       include 'COMMON.GEO'
4159       include 'COMMON.VAR'
4160       include 'COMMON.LOCAL'
4161       include 'COMMON.CHAIN'
4162       include 'COMMON.DERIV'
4163       include 'COMMON.INTERACT'
4164       include 'COMMON.FFIELD'
4165       include 'COMMON.IOUNITS'
4166       include 'COMMON.CONTROL'
4167       dimension ggg(3)
4168       evdw2=0.0D0
4169       evdw2_14=0.0d0
4170 cd    print '(a)','Enter ESCP'
4171 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4172       do i=iatscp_s,iatscp_e
4173         iteli=itel(i)
4174         xi=0.5D0*(c(1,i)+c(1,i+1))
4175         yi=0.5D0*(c(2,i)+c(2,i+1))
4176         zi=0.5D0*(c(3,i)+c(3,i+1))
4177
4178         do iint=1,nscp_gr(i)
4179
4180         do j=iscpstart(i,iint),iscpend(i,iint)
4181           itypj=itype(j)
4182 C Uncomment following three lines for SC-p interactions
4183 c         xj=c(1,nres+j)-xi
4184 c         yj=c(2,nres+j)-yi
4185 c         zj=c(3,nres+j)-zi
4186 C Uncomment following three lines for Ca-p interactions
4187           xj=c(1,j)-xi
4188           yj=c(2,j)-yi
4189           zj=c(3,j)-zi
4190           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4191           fac=rrij**expon2
4192           e1=fac*fac*aad(itypj,iteli)
4193           e2=fac*bad(itypj,iteli)
4194           if (iabs(j-i) .le. 2) then
4195             e1=scal14*e1
4196             e2=scal14*e2
4197             evdw2_14=evdw2_14+e1+e2
4198           endif
4199           evdwij=e1+e2
4200           evdw2=evdw2+evdwij
4201           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4202      &        'evdw2',i,j,evdwij
4203 C
4204 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4205 C
4206           fac=-(evdwij+e1)*rrij
4207           ggg(1)=xj*fac
4208           ggg(2)=yj*fac
4209           ggg(3)=zj*fac
4210 cgrad          if (j.lt.i) then
4211 cd          write (iout,*) 'j<i'
4212 C Uncomment following three lines for SC-p interactions
4213 c           do k=1,3
4214 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4215 c           enddo
4216 cgrad          else
4217 cd          write (iout,*) 'j>i'
4218 cgrad            do k=1,3
4219 cgrad              ggg(k)=-ggg(k)
4220 C Uncomment following line for SC-p interactions
4221 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4222 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4223 cgrad            enddo
4224 cgrad          endif
4225 cgrad          do k=1,3
4226 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4227 cgrad          enddo
4228 cgrad          kstart=min0(i+1,j)
4229 cgrad          kend=max0(i-1,j-1)
4230 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4231 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4232 cgrad          do k=kstart,kend
4233 cgrad            do l=1,3
4234 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4235 cgrad            enddo
4236 cgrad          enddo
4237           do k=1,3
4238             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4239             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4240           enddo
4241         enddo
4242
4243         enddo ! iint
4244       enddo ! i
4245       do i=1,nct
4246         do j=1,3
4247           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4248           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4249           gradx_scp(j,i)=expon*gradx_scp(j,i)
4250         enddo
4251       enddo
4252 C******************************************************************************
4253 C
4254 C                              N O T E !!!
4255 C
4256 C To save time the factor EXPON has been extracted from ALL components
4257 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4258 C use!
4259 C
4260 C******************************************************************************
4261       return
4262       end
4263 C--------------------------------------------------------------------------
4264       subroutine edis(ehpb)
4265 C
4266 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4267 C
4268       implicit real*8 (a-h,o-z)
4269       include 'DIMENSIONS'
4270       include 'COMMON.SBRIDGE'
4271       include 'COMMON.CHAIN'
4272       include 'COMMON.DERIV'
4273       include 'COMMON.VAR'
4274       include 'COMMON.INTERACT'
4275       include 'COMMON.IOUNITS'
4276       dimension ggg(3)
4277       ehpb=0.0D0
4278 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4279 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4280       if (link_end.eq.0) return
4281       do i=link_start,link_end
4282 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4283 C CA-CA distance used in regularization of structure.
4284         ii=ihpb(i)
4285         jj=jhpb(i)
4286 C iii and jjj point to the residues for which the distance is assigned.
4287         if (ii.gt.nres) then
4288           iii=ii-nres
4289           jjj=jj-nres
4290         else
4291           iii=ii
4292           jjj=jj
4293         endif
4294 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4295 c     &    dhpb(i),dhpb1(i),forcon(i)
4296 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4297 C    distance and angle dependent SS bond potential.
4298 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4299 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4300         if (.not.dyn_ss .and. i.le.nss) then
4301 C 15/02/13 CC dynamic SSbond - additional check
4302          if (ii.gt.nres
4303      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4304           call ssbond_ene(iii,jjj,eij)
4305           ehpb=ehpb+2*eij
4306          endif
4307 cd          write (iout,*) "eij",eij
4308         else if (ii.gt.nres .and. jj.gt.nres) then
4309 c Restraints from contact prediction
4310           dd=dist(ii,jj)
4311           if (dhpb1(i).gt.0.0d0) then
4312             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4313             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4314 c            write (iout,*) "beta nmr",
4315 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4316           else
4317             dd=dist(ii,jj)
4318             rdis=dd-dhpb(i)
4319 C Get the force constant corresponding to this distance.
4320             waga=forcon(i)
4321 C Calculate the contribution to energy.
4322             ehpb=ehpb+waga*rdis*rdis
4323 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4324 C
4325 C Evaluate gradient.
4326 C
4327             fac=waga*rdis/dd
4328           endif
4329           do j=1,3
4330             ggg(j)=fac*(c(j,jj)-c(j,ii))
4331           enddo
4332           do j=1,3
4333             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4334             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4335           enddo
4336           do k=1,3
4337             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4338             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4339           enddo
4340         else
4341 C Calculate the distance between the two points and its difference from the
4342 C target distance.
4343           dd=dist(ii,jj)
4344           if (dhpb1(i).gt.0.0d0) then
4345             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4346             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4347 c            write (iout,*) "alph nmr",
4348 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4349           else
4350             rdis=dd-dhpb(i)
4351 C Get the force constant corresponding to this distance.
4352             waga=forcon(i)
4353 C Calculate the contribution to energy.
4354             ehpb=ehpb+waga*rdis*rdis
4355 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4356 C
4357 C Evaluate gradient.
4358 C
4359             fac=waga*rdis/dd
4360           endif
4361 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4362 cd   &   ' waga=',waga,' fac=',fac
4363             do j=1,3
4364               ggg(j)=fac*(c(j,jj)-c(j,ii))
4365             enddo
4366 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4367 C If this is a SC-SC distance, we need to calculate the contributions to the
4368 C Cartesian gradient in the SC vectors (ghpbx).
4369           if (iii.lt.ii) then
4370           do j=1,3
4371             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4372             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4373           enddo
4374           endif
4375 cgrad        do j=iii,jjj-1
4376 cgrad          do k=1,3
4377 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4378 cgrad          enddo
4379 cgrad        enddo
4380           do k=1,3
4381             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4382             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4383           enddo
4384         endif
4385       enddo
4386       ehpb=0.5D0*ehpb
4387       return
4388       end
4389 C--------------------------------------------------------------------------
4390       subroutine ssbond_ene(i,j,eij)
4391 C
4392 C Calculate the distance and angle dependent SS-bond potential energy
4393 C using a free-energy function derived based on RHF/6-31G** ab initio
4394 C calculations of diethyl disulfide.
4395 C
4396 C A. Liwo and U. Kozlowska, 11/24/03
4397 C
4398       implicit real*8 (a-h,o-z)
4399       include 'DIMENSIONS'
4400       include 'COMMON.SBRIDGE'
4401       include 'COMMON.CHAIN'
4402       include 'COMMON.DERIV'
4403       include 'COMMON.LOCAL'
4404       include 'COMMON.INTERACT'
4405       include 'COMMON.VAR'
4406       include 'COMMON.IOUNITS'
4407       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4408       itypi=itype(i)
4409       xi=c(1,nres+i)
4410       yi=c(2,nres+i)
4411       zi=c(3,nres+i)
4412       dxi=dc_norm(1,nres+i)
4413       dyi=dc_norm(2,nres+i)
4414       dzi=dc_norm(3,nres+i)
4415 c      dsci_inv=dsc_inv(itypi)
4416       dsci_inv=vbld_inv(nres+i)
4417       itypj=itype(j)
4418 c      dscj_inv=dsc_inv(itypj)
4419       dscj_inv=vbld_inv(nres+j)
4420       xj=c(1,nres+j)-xi
4421       yj=c(2,nres+j)-yi
4422       zj=c(3,nres+j)-zi
4423       dxj=dc_norm(1,nres+j)
4424       dyj=dc_norm(2,nres+j)
4425       dzj=dc_norm(3,nres+j)
4426       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4427       rij=dsqrt(rrij)
4428       erij(1)=xj*rij
4429       erij(2)=yj*rij
4430       erij(3)=zj*rij
4431       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4432       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4433       om12=dxi*dxj+dyi*dyj+dzi*dzj
4434       do k=1,3
4435         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4436         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4437       enddo
4438       rij=1.0d0/rij
4439       deltad=rij-d0cm
4440       deltat1=1.0d0-om1
4441       deltat2=1.0d0+om2
4442       deltat12=om2-om1+2.0d0
4443       cosphi=om12-om1*om2
4444       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4445      &  +akct*deltad*deltat12+ebr
4446      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4447 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4448 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4449 c     &  " deltat12",deltat12," eij",eij
4450       ed=2*akcm*deltad+akct*deltat12
4451       pom1=akct*deltad
4452       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4453       eom1=-2*akth*deltat1-pom1-om2*pom2
4454       eom2= 2*akth*deltat2+pom1-om1*pom2
4455       eom12=pom2
4456       do k=1,3
4457         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4458         ghpbx(k,i)=ghpbx(k,i)-ggk
4459      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4460      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4461         ghpbx(k,j)=ghpbx(k,j)+ggk
4462      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4463      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4464         ghpbc(k,i)=ghpbc(k,i)-ggk
4465         ghpbc(k,j)=ghpbc(k,j)+ggk
4466       enddo
4467 C
4468 C Calculate the components of the gradient in DC and X
4469 C
4470 cgrad      do k=i,j-1
4471 cgrad        do l=1,3
4472 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4473 cgrad        enddo
4474 cgrad      enddo
4475       return
4476       end
4477 C--------------------------------------------------------------------------
4478       subroutine ebond(estr)
4479 c
4480 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4481 c
4482       implicit real*8 (a-h,o-z)
4483       include 'DIMENSIONS'
4484       include 'COMMON.LOCAL'
4485       include 'COMMON.GEO'
4486       include 'COMMON.INTERACT'
4487       include 'COMMON.DERIV'
4488       include 'COMMON.VAR'
4489       include 'COMMON.CHAIN'
4490       include 'COMMON.IOUNITS'
4491       include 'COMMON.NAMES'
4492       include 'COMMON.FFIELD'
4493       include 'COMMON.CONTROL'
4494       include 'COMMON.SETUP'
4495       double precision u(3),ud(3)
4496       estr=0.0d0
4497       do i=ibondp_start,ibondp_end
4498         diff = vbld(i)-vbldp0
4499 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4500         estr=estr+diff*diff
4501         do j=1,3
4502           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4503         enddo
4504 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4505       enddo
4506       estr=0.5d0*AKP*estr
4507 c
4508 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4509 c
4510       do i=ibond_start,ibond_end
4511         iti=itype(i)
4512         if (iti.ne.10) then
4513           nbi=nbondterm(iti)
4514           if (nbi.eq.1) then
4515             diff=vbld(i+nres)-vbldsc0(1,iti)
4516 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4517 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4518             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4519             do j=1,3
4520               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4521             enddo
4522           else
4523             do j=1,nbi
4524               diff=vbld(i+nres)-vbldsc0(j,iti)
4525               ud(j)=aksc(j,iti)*diff
4526               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4527             enddo
4528             uprod=u(1)
4529             do j=2,nbi
4530               uprod=uprod*u(j)
4531             enddo
4532             usum=0.0d0
4533             usumsqder=0.0d0
4534             do j=1,nbi
4535               uprod1=1.0d0
4536               uprod2=1.0d0
4537               do k=1,nbi
4538                 if (k.ne.j) then
4539                   uprod1=uprod1*u(k)
4540                   uprod2=uprod2*u(k)*u(k)
4541                 endif
4542               enddo
4543               usum=usum+uprod1
4544               usumsqder=usumsqder+ud(j)*uprod2
4545             enddo
4546             estr=estr+uprod/usum
4547             do j=1,3
4548              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4549             enddo
4550           endif
4551         endif
4552       enddo
4553       return
4554       end
4555 #ifdef CRYST_THETA
4556 C--------------------------------------------------------------------------
4557       subroutine ebend(etheta)
4558 C
4559 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4560 C angles gamma and its derivatives in consecutive thetas and gammas.
4561 C
4562       implicit real*8 (a-h,o-z)
4563       include 'DIMENSIONS'
4564       include 'COMMON.LOCAL'
4565       include 'COMMON.GEO'
4566       include 'COMMON.INTERACT'
4567       include 'COMMON.DERIV'
4568       include 'COMMON.VAR'
4569       include 'COMMON.CHAIN'
4570       include 'COMMON.IOUNITS'
4571       include 'COMMON.NAMES'
4572       include 'COMMON.FFIELD'
4573       include 'COMMON.CONTROL'
4574       common /calcthet/ term1,term2,termm,diffak,ratak,
4575      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4576      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4577       double precision y(2),z(2)
4578       delta=0.02d0*pi
4579 c      time11=dexp(-2*time)
4580 c      time12=1.0d0
4581       etheta=0.0D0
4582 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4583       do i=ithet_start,ithet_end
4584 C Zero the energy function and its derivative at 0 or pi.
4585         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4586         it=itype(i-1)
4587         ichir1=isign(1,itype(i-2))
4588         ichir2=isign(1,itype(i))
4589          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4590          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4591          if (itype(i-1).eq.10) then
4592           itype1=isign(10,itype(i-2))
4593           ichir11=isign(1,itype(i-2))
4594           ichir12=isign(1,itype(i-2))
4595           itype2=isign(10,itype(i))
4596           ichir21=isign(1,itype(i))
4597           ichir22=isign(1,itype(i))
4598          endif
4599         if (i.gt.3) then
4600 #ifdef OSF
4601           phii=phi(i)
4602           if (phii.ne.phii) phii=150.0
4603 #else
4604           phii=phi(i)
4605 #endif
4606           y(1)=dcos(phii)
4607           y(2)=dsin(phii)
4608         else
4609           y(1)=0.0D0
4610           y(2)=0.0D0
4611         endif
4612         if (i.lt.nres) then
4613 #ifdef OSF
4614           phii1=phi(i+1)
4615           if (phii1.ne.phii1) phii1=150.0
4616           phii1=pinorm(phii1)
4617           z(1)=cos(phii1)
4618 #else
4619           phii1=phi(i+1)
4620           z(1)=dcos(phii1)
4621 #endif
4622           z(2)=dsin(phii1)
4623         else
4624           z(1)=0.0D0
4625           z(2)=0.0D0
4626         endif
4627 C Calculate the "mean" value of theta from the part of the distribution
4628 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4629 C In following comments this theta will be referred to as t_c.
4630         thet_pred_mean=0.0d0
4631         do k=1,2
4632             athetk=athet(k,it,ichir1,ichir2)
4633             bthetk=bthet(k,it,ichir1,ichir2)
4634           if (it.eq.10) then
4635              athetk=athet(k,itype1,ichir11,ichir12)
4636              bthetk=bthet(k,itype2,ichir21,ichir22)
4637           endif
4638           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4639         enddo
4640         dthett=thet_pred_mean*ssd
4641         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4642 C Derivatives of the "mean" values in gamma1 and gamma2.
4643         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4644      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4645          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4646      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4647          if (it.eq.10) then
4648       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4649      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4650         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4651      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4652          endif
4653         if (theta(i).gt.pi-delta) then
4654           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4655      &         E_tc0)
4656           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4657           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4658           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4659      &        E_theta)
4660           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4661      &        E_tc)
4662         else if (theta(i).lt.delta) then
4663           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4664           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4665           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4666      &        E_theta)
4667           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4668           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4669      &        E_tc)
4670         else
4671           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4672      &        E_theta,E_tc)
4673         endif
4674         etheta=etheta+ethetai
4675         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4676      &      'ebend',i,ethetai
4677         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4678         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4679         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4680       enddo
4681 C Ufff.... We've done all this!!!
4682       return
4683       end
4684 C---------------------------------------------------------------------------
4685       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4686      &     E_tc)
4687       implicit real*8 (a-h,o-z)
4688       include 'DIMENSIONS'
4689       include 'COMMON.LOCAL'
4690       include 'COMMON.IOUNITS'
4691       common /calcthet/ term1,term2,termm,diffak,ratak,
4692      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4693      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4694 C Calculate the contributions to both Gaussian lobes.
4695 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4696 C The "polynomial part" of the "standard deviation" of this part of
4697 C the distribution.
4698         sig=polthet(3,it)
4699         do j=2,0,-1
4700           sig=sig*thet_pred_mean+polthet(j,it)
4701         enddo
4702 C Derivative of the "interior part" of the "standard deviation of the"
4703 C gamma-dependent Gaussian lobe in t_c.
4704         sigtc=3*polthet(3,it)
4705         do j=2,1,-1
4706           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4707         enddo
4708         sigtc=sig*sigtc
4709 C Set the parameters of both Gaussian lobes of the distribution.
4710 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4711         fac=sig*sig+sigc0(it)
4712         sigcsq=fac+fac
4713         sigc=1.0D0/sigcsq
4714 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4715         sigsqtc=-4.0D0*sigcsq*sigtc
4716 c       print *,i,sig,sigtc,sigsqtc
4717 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4718         sigtc=-sigtc/(fac*fac)
4719 C Following variable is sigma(t_c)**(-2)
4720         sigcsq=sigcsq*sigcsq
4721         sig0i=sig0(it)
4722         sig0inv=1.0D0/sig0i**2
4723         delthec=thetai-thet_pred_mean
4724         delthe0=thetai-theta0i
4725         term1=-0.5D0*sigcsq*delthec*delthec
4726         term2=-0.5D0*sig0inv*delthe0*delthe0
4727 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4728 C NaNs in taking the logarithm. We extract the largest exponent which is added
4729 C to the energy (this being the log of the distribution) at the end of energy
4730 C term evaluation for this virtual-bond angle.
4731         if (term1.gt.term2) then
4732           termm=term1
4733           term2=dexp(term2-termm)
4734           term1=1.0d0
4735         else
4736           termm=term2
4737           term1=dexp(term1-termm)
4738           term2=1.0d0
4739         endif
4740 C The ratio between the gamma-independent and gamma-dependent lobes of
4741 C the distribution is a Gaussian function of thet_pred_mean too.
4742         diffak=gthet(2,it)-thet_pred_mean
4743         ratak=diffak/gthet(3,it)**2
4744         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4745 C Let's differentiate it in thet_pred_mean NOW.
4746         aktc=ak*ratak
4747 C Now put together the distribution terms to make complete distribution.
4748         termexp=term1+ak*term2
4749         termpre=sigc+ak*sig0i
4750 C Contribution of the bending energy from this theta is just the -log of
4751 C the sum of the contributions from the two lobes and the pre-exponential
4752 C factor. Simple enough, isn't it?
4753         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4754 C NOW the derivatives!!!
4755 C 6/6/97 Take into account the deformation.
4756         E_theta=(delthec*sigcsq*term1
4757      &       +ak*delthe0*sig0inv*term2)/termexp
4758         E_tc=((sigtc+aktc*sig0i)/termpre
4759      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4760      &       aktc*term2)/termexp)
4761       return
4762       end
4763 c-----------------------------------------------------------------------------
4764       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4765       implicit real*8 (a-h,o-z)
4766       include 'DIMENSIONS'
4767       include 'COMMON.LOCAL'
4768       include 'COMMON.IOUNITS'
4769       common /calcthet/ term1,term2,termm,diffak,ratak,
4770      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4771      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4772       delthec=thetai-thet_pred_mean
4773       delthe0=thetai-theta0i
4774 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4775       t3 = thetai-thet_pred_mean
4776       t6 = t3**2
4777       t9 = term1
4778       t12 = t3*sigcsq
4779       t14 = t12+t6*sigsqtc
4780       t16 = 1.0d0
4781       t21 = thetai-theta0i
4782       t23 = t21**2
4783       t26 = term2
4784       t27 = t21*t26
4785       t32 = termexp
4786       t40 = t32**2
4787       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4788      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4789      & *(-t12*t9-ak*sig0inv*t27)
4790       return
4791       end
4792 #else
4793 C--------------------------------------------------------------------------
4794       subroutine ebend(etheta)
4795 C
4796 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4797 C angles gamma and its derivatives in consecutive thetas and gammas.
4798 C ab initio-derived potentials from
4799 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4800 C
4801       implicit real*8 (a-h,o-z)
4802       include 'DIMENSIONS'
4803       include 'COMMON.LOCAL'
4804       include 'COMMON.GEO'
4805       include 'COMMON.INTERACT'
4806       include 'COMMON.DERIV'
4807       include 'COMMON.VAR'
4808       include 'COMMON.CHAIN'
4809       include 'COMMON.IOUNITS'
4810       include 'COMMON.NAMES'
4811       include 'COMMON.FFIELD'
4812       include 'COMMON.CONTROL'
4813       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4814      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4815      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4816      & sinph1ph2(maxdouble,maxdouble)
4817       logical lprn /.false./, lprn1 /.false./
4818       etheta=0.0D0
4819       do i=ithet_start,ithet_end
4820         dethetai=0.0d0
4821         dephii=0.0d0
4822         dephii1=0.0d0
4823         theti2=0.5d0*theta(i)
4824         ityp2=ithetyp(itype(i-1))
4825         do k=1,nntheterm
4826           coskt(k)=dcos(k*theti2)
4827           sinkt(k)=dsin(k*theti2)
4828         enddo
4829         if (i.gt.3) then
4830 #ifdef OSF
4831           phii=phi(i)
4832           if (phii.ne.phii) phii=150.0
4833 #else
4834           phii=phi(i)
4835 #endif
4836           ityp1=ithetyp(itype(i-2))
4837           do k=1,nsingle
4838             cosph1(k)=dcos(k*phii)
4839             sinph1(k)=dsin(k*phii)
4840           enddo
4841         else
4842           phii=0.0d0
4843           ityp1=nthetyp+1
4844           do k=1,nsingle
4845             cosph1(k)=0.0d0
4846             sinph1(k)=0.0d0
4847           enddo
4848         endif
4849         if (i.lt.nres) then
4850
4851         if (iabs(itype(i+1)).eq.20) iblock=2
4852         if (iabs(itype(i+1)).ne.20) iblock=1
4853 #ifdef OSF
4854           phii1=phi(i+1)
4855           if (phii1.ne.phii1) phii1=150.0
4856           phii1=pinorm(phii1)
4857 #else
4858           phii1=phi(i+1)
4859 #endif
4860           ityp3=ithetyp(itype(i))
4861           do k=1,nsingle
4862             cosph2(k)=dcos(k*phii1)
4863             sinph2(k)=dsin(k*phii1)
4864           enddo
4865         else
4866           phii1=0.0d0
4867           ityp3=nthetyp+1
4868           do k=1,nsingle
4869             cosph2(k)=0.0d0
4870             sinph2(k)=0.0d0
4871           enddo
4872         endif
4873          ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4874         do k=1,ndouble
4875           do l=1,k-1
4876             ccl=cosph1(l)*cosph2(k-l)
4877             ssl=sinph1(l)*sinph2(k-l)
4878             scl=sinph1(l)*cosph2(k-l)
4879             csl=cosph1(l)*sinph2(k-l)
4880             cosph1ph2(l,k)=ccl-ssl
4881             cosph1ph2(k,l)=ccl+ssl
4882             sinph1ph2(l,k)=scl+csl
4883             sinph1ph2(k,l)=scl-csl
4884           enddo
4885         enddo
4886         if (lprn) then
4887         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4888      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4889         write (iout,*) "coskt and sinkt"
4890         do k=1,nntheterm
4891           write (iout,*) k,coskt(k),sinkt(k)
4892         enddo
4893         endif
4894         do k=1,ntheterm
4895           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4896           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4897      &      *coskt(k)
4898           if (lprn)
4899      &    write (iout,*) "k",k,
4900      &    "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4901      &     " ethetai",ethetai
4902         enddo
4903         if (lprn) then
4904         write (iout,*) "cosph and sinph"
4905         do k=1,nsingle
4906           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4907         enddo
4908         write (iout,*) "cosph1ph2 and sinph2ph2"
4909         do k=2,ndouble
4910           do l=1,k-1
4911             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4912      &         sinph1ph2(l,k),sinph1ph2(k,l)
4913           enddo
4914         enddo
4915         write(iout,*) "ethetai",ethetai
4916         endif
4917         do m=1,ntheterm2
4918           do k=1,nsingle
4919             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4920      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4921      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4922      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4923             ethetai=ethetai+sinkt(m)*aux
4924             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4925             dephii=dephii+k*sinkt(m)*(
4926      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4927      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4928             dephii1=dephii1+k*sinkt(m)*(
4929      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4930      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4931             if (lprn)
4932      &      write (iout,*) "m",m," k",k," bbthet",
4933      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4934      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4935      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4936      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4937           enddo
4938         enddo
4939         if (lprn)
4940      &  write(iout,*) "ethetai",ethetai
4941         do m=1,ntheterm3
4942           do k=2,ndouble
4943             do l=1,k-1
4944        aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4945      & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4946      & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4947      & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4948
4949               ethetai=ethetai+sinkt(m)*aux
4950               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4951               dephii=dephii+l*sinkt(m)*(
4952      & -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4953      &  ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4954      &  ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4955      &  ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4956
4957               dephii1=dephii1+(k-l)*sinkt(m)*(
4958      &-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4959      & ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4960      & ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4961      & ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4962
4963               if (lprn) then
4964               write (iout,*) "m",m," k",k," l",l," ffthet",
4965      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4966      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4967      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4968      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4969      &            " ethetai",ethetai
4970
4971               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4972      &            cosph1ph2(k,l)*sinkt(m),
4973      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4974               endif
4975             enddo
4976           enddo
4977         enddo
4978 10      continue
4979 c        lprn1=.true.
4980         if (lprn1) write (iout,'(a4,i2,3f8.1,9h ethetai ,f10.5)')
4981      &  'ebe', i,theta(i)*rad2deg,phii*rad2deg,
4982      &   phii1*rad2deg,ethetai
4983 c        lprn1=.false.
4984         etheta=etheta+ethetai
4985         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4986         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4987         gloc(nphi+i-2,icg)=wang*dethetai
4988       enddo
4989       return
4990       end
4991 #endif
4992 #ifdef CRYST_SC
4993 c-----------------------------------------------------------------------------
4994       subroutine esc(escloc)
4995 C Calculate the local energy of a side chain and its derivatives in the
4996 C corresponding virtual-bond valence angles THETA and the spherical angles
4997 C ALPHA and OMEGA.
4998       implicit real*8 (a-h,o-z)
4999       include 'DIMENSIONS'
5000       include 'COMMON.GEO'
5001       include 'COMMON.LOCAL'
5002       include 'COMMON.VAR'
5003       include 'COMMON.INTERACT'
5004       include 'COMMON.DERIV'
5005       include 'COMMON.CHAIN'
5006       include 'COMMON.IOUNITS'
5007       include 'COMMON.NAMES'
5008       include 'COMMON.FFIELD'
5009       include 'COMMON.CONTROL'
5010       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5011      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5012       common /sccalc/ time11,time12,time112,theti,it,nlobit
5013       delta=0.02d0*pi
5014       escloc=0.0D0
5015 c     write (iout,'(a)') 'ESC'
5016       do i=loc_start,loc_end
5017         it=itype(i)
5018         if (it.eq.10) goto 1
5019         nlobit=nlob(it)
5020 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5021 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5022         theti=theta(i+1)-pipol
5023         x(1)=dtan(theti)
5024         x(2)=alph(i)
5025         x(3)=omeg(i)
5026
5027         if (x(2).gt.pi-delta) then
5028           xtemp(1)=x(1)
5029           xtemp(2)=pi-delta
5030           xtemp(3)=x(3)
5031           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5032           xtemp(2)=pi
5033           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5034           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5035      &        escloci,dersc(2))
5036           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5037      &        ddersc0(1),dersc(1))
5038           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5039      &        ddersc0(3),dersc(3))
5040           xtemp(2)=pi-delta
5041           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5042           xtemp(2)=pi
5043           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5044           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5045      &            dersc0(2),esclocbi,dersc02)
5046           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5047      &            dersc12,dersc01)
5048           call splinthet(x(2),0.5d0*delta,ss,ssd)
5049           dersc0(1)=dersc01
5050           dersc0(2)=dersc02
5051           dersc0(3)=0.0d0
5052           do k=1,3
5053             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5054           enddo
5055           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5056 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5057 c    &             esclocbi,ss,ssd
5058           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5059 c         escloci=esclocbi
5060 c         write (iout,*) escloci
5061         else if (x(2).lt.delta) then
5062           xtemp(1)=x(1)
5063           xtemp(2)=delta
5064           xtemp(3)=x(3)
5065           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5066           xtemp(2)=0.0d0
5067           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5068           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5069      &        escloci,dersc(2))
5070           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5071      &        ddersc0(1),dersc(1))
5072           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5073      &        ddersc0(3),dersc(3))
5074           xtemp(2)=delta
5075           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5076           xtemp(2)=0.0d0
5077           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5078           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5079      &            dersc0(2),esclocbi,dersc02)
5080           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5081      &            dersc12,dersc01)
5082           dersc0(1)=dersc01
5083           dersc0(2)=dersc02
5084           dersc0(3)=0.0d0
5085           call splinthet(x(2),0.5d0*delta,ss,ssd)
5086           do k=1,3
5087             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5088           enddo
5089           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5090 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5091 c    &             esclocbi,ss,ssd
5092           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5093 c         write (iout,*) escloci
5094         else
5095           call enesc(x,escloci,dersc,ddummy,.false.)
5096         endif
5097
5098         escloc=escloc+escloci
5099         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5100      &     'escloc',i,escloci
5101 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5102
5103         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5104      &   wscloc*dersc(1)
5105         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5106         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5107     1   continue
5108       enddo
5109       return
5110       end
5111 C---------------------------------------------------------------------------
5112       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5113       implicit real*8 (a-h,o-z)
5114       include 'DIMENSIONS'
5115       include 'COMMON.GEO'
5116       include 'COMMON.LOCAL'
5117       include 'COMMON.IOUNITS'
5118       common /sccalc/ time11,time12,time112,theti,it,nlobit
5119       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5120       double precision contr(maxlob,-1:1)
5121       logical mixed
5122 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5123         escloc_i=0.0D0
5124         do j=1,3
5125           dersc(j)=0.0D0
5126           if (mixed) ddersc(j)=0.0d0
5127         enddo
5128         x3=x(3)
5129
5130 C Because of periodicity of the dependence of the SC energy in omega we have
5131 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5132 C To avoid underflows, first compute & store the exponents.
5133
5134         do iii=-1,1
5135
5136           x(3)=x3+iii*dwapi
5137
5138           do j=1,nlobit
5139             do k=1,3
5140               z(k)=x(k)-censc(k,j,it)
5141             enddo
5142             do k=1,3
5143               Axk=0.0D0
5144               do l=1,3
5145                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5146               enddo
5147               Ax(k,j,iii)=Axk
5148             enddo
5149             expfac=0.0D0
5150             do k=1,3
5151               expfac=expfac+Ax(k,j,iii)*z(k)
5152             enddo
5153             contr(j,iii)=expfac
5154           enddo ! j
5155
5156         enddo ! iii
5157
5158         x(3)=x3
5159 C As in the case of ebend, we want to avoid underflows in exponentiation and
5160 C subsequent NaNs and INFs in energy calculation.
5161 C Find the largest exponent
5162         emin=contr(1,-1)
5163         do iii=-1,1
5164           do j=1,nlobit
5165             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5166           enddo
5167         enddo
5168         emin=0.5D0*emin
5169 cd      print *,'it=',it,' emin=',emin
5170
5171 C Compute the contribution to SC energy and derivatives
5172         do iii=-1,1
5173
5174           do j=1,nlobit
5175 #ifdef OSF
5176             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5177             if(adexp.ne.adexp) adexp=1.0
5178             expfac=dexp(adexp)
5179 #else
5180             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5181 #endif
5182 cd          print *,'j=',j,' expfac=',expfac
5183             escloc_i=escloc_i+expfac
5184             do k=1,3
5185               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5186             enddo
5187             if (mixed) then
5188               do k=1,3,2
5189                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5190      &            +gaussc(k,2,j,it))*expfac
5191               enddo
5192             endif
5193           enddo
5194
5195         enddo ! iii
5196
5197         dersc(1)=dersc(1)/cos(theti)**2
5198         ddersc(1)=ddersc(1)/cos(theti)**2
5199         ddersc(3)=ddersc(3)
5200
5201         escloci=-(dlog(escloc_i)-emin)
5202         do j=1,3
5203           dersc(j)=dersc(j)/escloc_i
5204         enddo
5205         if (mixed) then
5206           do j=1,3,2
5207             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5208           enddo
5209         endif
5210       return
5211       end
5212 C------------------------------------------------------------------------------
5213       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5214       implicit real*8 (a-h,o-z)
5215       include 'DIMENSIONS'
5216       include 'COMMON.GEO'
5217       include 'COMMON.LOCAL'
5218       include 'COMMON.IOUNITS'
5219       common /sccalc/ time11,time12,time112,theti,it,nlobit
5220       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5221       double precision contr(maxlob)
5222       logical mixed
5223
5224       escloc_i=0.0D0
5225
5226       do j=1,3
5227         dersc(j)=0.0D0
5228       enddo
5229
5230       do j=1,nlobit
5231         do k=1,2
5232           z(k)=x(k)-censc(k,j,it)
5233         enddo
5234         z(3)=dwapi
5235         do k=1,3
5236           Axk=0.0D0
5237           do l=1,3
5238             Axk=Axk+gaussc(l,k,j,it)*z(l)
5239           enddo
5240           Ax(k,j)=Axk
5241         enddo
5242         expfac=0.0D0
5243         do k=1,3
5244           expfac=expfac+Ax(k,j)*z(k)
5245         enddo
5246         contr(j)=expfac
5247       enddo ! j
5248
5249 C As in the case of ebend, we want to avoid underflows in exponentiation and
5250 C subsequent NaNs and INFs in energy calculation.
5251 C Find the largest exponent
5252       emin=contr(1)
5253       do j=1,nlobit
5254         if (emin.gt.contr(j)) emin=contr(j)
5255       enddo
5256       emin=0.5D0*emin
5257
5258 C Compute the contribution to SC energy and derivatives
5259
5260       dersc12=0.0d0
5261       do j=1,nlobit
5262         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5263         escloc_i=escloc_i+expfac
5264         do k=1,2
5265           dersc(k)=dersc(k)+Ax(k,j)*expfac
5266         enddo
5267         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5268      &            +gaussc(1,2,j,it))*expfac
5269         dersc(3)=0.0d0
5270       enddo
5271
5272       dersc(1)=dersc(1)/cos(theti)**2
5273       dersc12=dersc12/cos(theti)**2
5274       escloci=-(dlog(escloc_i)-emin)
5275       do j=1,2
5276         dersc(j)=dersc(j)/escloc_i
5277       enddo
5278       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5279       return
5280       end
5281 #else
5282 c----------------------------------------------------------------------------------
5283       subroutine esc(escloc)
5284 C Calculate the local energy of a side chain and its derivatives in the
5285 C corresponding virtual-bond valence angles THETA and the spherical angles
5286 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5287 C added by Urszula Kozlowska. 07/11/2007
5288 C
5289       implicit real*8 (a-h,o-z)
5290       include 'DIMENSIONS'
5291       include 'COMMON.GEO'
5292       include 'COMMON.LOCAL'
5293       include 'COMMON.VAR'
5294       include 'COMMON.SCROT'
5295       include 'COMMON.INTERACT'
5296       include 'COMMON.DERIV'
5297       include 'COMMON.CHAIN'
5298       include 'COMMON.IOUNITS'
5299       include 'COMMON.NAMES'
5300       include 'COMMON.FFIELD'
5301       include 'COMMON.CONTROL'
5302       include 'COMMON.VECTORS'
5303       double precision x_prime(3),y_prime(3),z_prime(3)
5304      &    , sumene,dsc_i,dp2_i,x(65),
5305      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5306      &    de_dxx,de_dyy,de_dzz,de_dt
5307       double precision s1_t,s1_6_t,s2_t,s2_6_t
5308       double precision
5309      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5310      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5311      & dt_dCi(3),dt_dCi1(3)
5312       common /sccalc/ time11,time12,time112,theti,it,nlobit
5313       delta=0.02d0*pi
5314       escloc=0.0D0
5315       do i=loc_start,loc_end
5316         costtab(i+1) =dcos(theta(i+1))
5317         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5318         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5319         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5320         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5321         cosfac=dsqrt(cosfac2)
5322         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5323         sinfac=dsqrt(sinfac2)
5324         it=iabs(itype(i))
5325         if (it.eq.10) goto 1
5326 c
5327 C  Compute the axes of tghe local cartesian coordinates system; store in
5328 c   x_prime, y_prime and z_prime
5329 c
5330         do j=1,3
5331           x_prime(j) = 0.00
5332           y_prime(j) = 0.00
5333           z_prime(j) = 0.00
5334         enddo
5335 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5336 C     &   dc_norm(3,i+nres)
5337         do j = 1,3
5338           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5339           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5340         enddo
5341         do j = 1,3
5342           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5343         enddo
5344 c       write (2,*) "i",i
5345 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5346 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5347 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5348 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5349 c      & " xy",scalar(x_prime(1),y_prime(1)),
5350 c      & " xz",scalar(x_prime(1),z_prime(1)),
5351 c      & " yy",scalar(y_prime(1),y_prime(1)),
5352 c      & " yz",scalar(y_prime(1),z_prime(1)),
5353 c      & " zz",scalar(z_prime(1),z_prime(1))
5354 c
5355 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5356 C to local coordinate system. Store in xx, yy, zz.
5357 c
5358         xx=0.0d0
5359         yy=0.0d0
5360         zz=0.0d0
5361         do j = 1,3
5362           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5363           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5364           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5365         enddo
5366
5367         xxtab(i)=xx
5368         yytab(i)=yy
5369         zztab(i)=zz
5370 C
5371 C Compute the energy of the ith side cbain
5372 C
5373 c        write (2,*) "xx",xx," yy",yy," zz",zz
5374         it=iabs(itype(i))
5375         do j = 1,65
5376           x(j) = sc_parmin(j,it)
5377         enddo
5378 #ifdef CHECK_COORD
5379 Cc diagnostics - remove later
5380         xx1 = dcos(alph(2))
5381         yy1 = dsin(alph(2))*dcos(omeg(2))
5382         zz1 = -dsign(1.0, dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5383         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5384      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5385      &    xx1,yy1,zz1
5386 C,"  --- ", xx_w,yy_w,zz_w
5387 c end diagnostics
5388 #endif
5389         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5390      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5391      &   + x(10)*yy*zz
5392         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5393      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5394      & + x(20)*yy*zz
5395         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5396      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5397      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5398      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5399      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5400      &  +x(40)*xx*yy*zz
5401         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5402      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5403      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5404      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5405      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5406      &  +x(60)*xx*yy*zz
5407         dsc_i   = 0.743d0+x(61)
5408         dp2_i   = 1.9d0+x(62)
5409         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5410      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5411         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5412      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5413         s1=(1+x(63))/(0.1d0 + dscp1)
5414         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5415         s2=(1+x(65))/(0.1d0 + dscp2)
5416         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5417         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5418      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5419 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5420 c     &   sumene4,
5421 c     &   dscp1,dscp2,sumene
5422 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5423         escloc = escloc + sumene
5424 c        write (2,*) "i",i," escloc",sumene,escloc
5425 #ifdef DEBUG
5426 C
5427 C This section to check the numerical derivatives of the energy of ith side
5428 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5429 C #define DEBUG in the code to turn it on.
5430 C
5431         write (2,*) "sumene               =",sumene
5432         aincr=1.0d-7
5433         xxsave=xx
5434         xx=xx+aincr
5435         write (2,*) xx,yy,zz
5436         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5437         de_dxx_num=(sumenep-sumene)/aincr
5438         xx=xxsave
5439         write (2,*) "xx+ sumene from enesc=",sumenep
5440         yysave=yy
5441         yy=yy+aincr
5442         write (2,*) xx,yy,zz
5443         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5444         de_dyy_num=(sumenep-sumene)/aincr
5445         yy=yysave
5446         write (2,*) "yy+ sumene from enesc=",sumenep
5447         zzsave=zz
5448         zz=zz+aincr
5449         write (2,*) xx,yy,zz
5450         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5451         de_dzz_num=(sumenep-sumene)/aincr
5452         zz=zzsave
5453         write (2,*) "zz+ sumene from enesc=",sumenep
5454         costsave=cost2tab(i+1)
5455         sintsave=sint2tab(i+1)
5456         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5457         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5458         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5459         de_dt_num=(sumenep-sumene)/aincr
5460         write (2,*) " t+ sumene from enesc=",sumenep
5461         cost2tab(i+1)=costsave
5462         sint2tab(i+1)=sintsave
5463 C End of diagnostics section.
5464 #endif
5465 C
5466 C Compute the gradient of esc
5467 C
5468         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5469         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5470         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5471         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5472         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5473         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5474         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5475         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5476         pom1=(sumene3*sint2tab(i+1)+sumene1)
5477      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5478         pom2=(sumene4*cost2tab(i+1)+sumene2)
5479      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5480         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5481         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5482      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5483      &  +x(40)*yy*zz
5484         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5485         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5486      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5487      &  +x(60)*yy*zz
5488         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5489      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5490      &        +(pom1+pom2)*pom_dx
5491 #ifdef DEBUG
5492         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5493 #endif
5494 C
5495         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5496         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5497      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5498      &  +x(40)*xx*zz
5499         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5500         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5501      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5502      &  +x(59)*zz**2 +x(60)*xx*zz
5503         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5504      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5505      &        +(pom1-pom2)*pom_dy
5506 #ifdef DEBUG
5507         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5508 #endif
5509 C
5510         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5511      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5512      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5513      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5514      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5515      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5516      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5517      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5518 #ifdef DEBUG
5519         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5520 #endif
5521 C
5522         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5523      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5524      &  +pom1*pom_dt1+pom2*pom_dt2
5525 #ifdef DEBUG
5526         write(2,*), "de_dt = ", de_dt,de_dt_num
5527 #endif
5528 c
5529 C
5530        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5531        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5532        cosfac2xx=cosfac2*xx
5533        sinfac2yy=sinfac2*yy
5534        do k = 1,3
5535          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5536      &      vbld_inv(i+1)
5537          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5538      &      vbld_inv(i)
5539          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5540          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5541 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5542 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5543 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5544 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5545          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5546          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5547          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5548          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5549          dZZ_Ci1(k)=0.0d0
5550          dZZ_Ci(k)=0.0d0
5551          do j=1,3
5552            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5553      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5554            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5555      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5556          enddo
5557
5558          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5559          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5560          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5561 c
5562          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5563          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5564        enddo
5565
5566        do k=1,3
5567          dXX_Ctab(k,i)=dXX_Ci(k)
5568          dXX_C1tab(k,i)=dXX_Ci1(k)
5569          dYY_Ctab(k,i)=dYY_Ci(k)
5570          dYY_C1tab(k,i)=dYY_Ci1(k)
5571          dZZ_Ctab(k,i)=dZZ_Ci(k)
5572          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5573          dXX_XYZtab(k,i)=dXX_XYZ(k)
5574          dYY_XYZtab(k,i)=dYY_XYZ(k)
5575          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5576        enddo
5577
5578        do k = 1,3
5579 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5580 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5581 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5582 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5583 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5584 c     &    dt_dci(k)
5585 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5586 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5587          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5588      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5589          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5590      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5591          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5592      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5593        enddo
5594 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5595 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5596
5597 C to check gradient call subroutine check_grad
5598
5599     1 continue
5600       enddo
5601       return
5602       end
5603 c------------------------------------------------------------------------------
5604       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5605       implicit none
5606       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5607      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5608       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5609      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5610      &   + x(10)*yy*zz
5611       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5612      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5613      & + x(20)*yy*zz
5614       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5615      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5616      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5617      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5618      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5619      &  +x(40)*xx*yy*zz
5620       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5621      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5622      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5623      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5624      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5625      &  +x(60)*xx*yy*zz
5626       dsc_i   = 0.743d0+x(61)
5627       dp2_i   = 1.9d0+x(62)
5628       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5629      &          *(xx*cost2+yy*sint2))
5630       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5631      &          *(xx*cost2-yy*sint2))
5632       s1=(1+x(63))/(0.1d0 + dscp1)
5633       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5634       s2=(1+x(65))/(0.1d0 + dscp2)
5635       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5636       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5637      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5638       enesc=sumene
5639       return
5640       end
5641 #endif
5642 c------------------------------------------------------------------------------
5643       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5644 C
5645 C This procedure calculates two-body contact function g(rij) and its derivative:
5646 C
5647 C           eps0ij                                     !       x < -1
5648 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5649 C            0                                         !       x > 1
5650 C
5651 C where x=(rij-r0ij)/delta
5652 C
5653 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5654 C
5655       implicit none
5656       double precision rij,r0ij,eps0ij,fcont,fprimcont
5657       double precision x,x2,x4,delta
5658 c     delta=0.02D0*r0ij
5659 c      delta=0.2D0*r0ij
5660       x=(rij-r0ij)/delta
5661       if (x.lt.-1.0D0) then
5662         fcont=eps0ij
5663         fprimcont=0.0D0
5664       else if (x.le.1.0D0) then
5665         x2=x*x
5666         x4=x2*x2
5667         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5668         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5669       else
5670         fcont=0.0D0
5671         fprimcont=0.0D0
5672       endif
5673       return
5674       end
5675 c------------------------------------------------------------------------------
5676       subroutine splinthet(theti,delta,ss,ssder)
5677       implicit real*8 (a-h,o-z)
5678       include 'DIMENSIONS'
5679       include 'COMMON.VAR'
5680       include 'COMMON.GEO'
5681       thetup=pi-delta
5682       thetlow=delta
5683       if (theti.gt.pipol) then
5684         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5685       else
5686         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5687         ssder=-ssder
5688       endif
5689       return
5690       end
5691 c------------------------------------------------------------------------------
5692       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5693       implicit none
5694       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5695       double precision ksi,ksi2,ksi3,a1,a2,a3
5696       a1=fprim0*delta/(f1-f0)
5697       a2=3.0d0-2.0d0*a1
5698       a3=a1-2.0d0
5699       ksi=(x-x0)/delta
5700       ksi2=ksi*ksi
5701       ksi3=ksi2*ksi
5702       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5703       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5704       return
5705       end
5706 c------------------------------------------------------------------------------
5707       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5708       implicit none
5709       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5710       double precision ksi,ksi2,ksi3,a1,a2,a3
5711       ksi=(x-x0)/delta
5712       ksi2=ksi*ksi
5713       ksi3=ksi2*ksi
5714       a1=fprim0x*delta
5715       a2=3*(f1x-f0x)-2*fprim0x*delta
5716       a3=fprim0x*delta-2*(f1x-f0x)
5717       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5718       return
5719       end
5720 C-----------------------------------------------------------------------------
5721 #ifdef CRYST_TOR
5722 C-----------------------------------------------------------------------------
5723       subroutine etor(etors,edihcnstr)
5724       implicit real*8 (a-h,o-z)
5725       include 'DIMENSIONS'
5726       include 'COMMON.VAR'
5727       include 'COMMON.GEO'
5728       include 'COMMON.LOCAL'
5729       include 'COMMON.TORSION'
5730       include 'COMMON.INTERACT'
5731       include 'COMMON.DERIV'
5732       include 'COMMON.CHAIN'
5733       include 'COMMON.NAMES'
5734       include 'COMMON.IOUNITS'
5735       include 'COMMON.FFIELD'
5736       include 'COMMON.TORCNSTR'
5737       include 'COMMON.CONTROL'
5738       logical lprn
5739 C Set lprn=.true. for debugging
5740       lprn=.false.
5741 c      lprn=.true.
5742       etors=0.0D0
5743       do i=iphi_start,iphi_end
5744       etors_ii=0.0D0
5745         itori=itortyp(itype(i-2))
5746         itori1=itortyp(itype(i-1))
5747         phii=phi(i)
5748         gloci=0.0D0
5749 C Proline-Proline pair is a special case...
5750         if (itori.eq.3 .and. itori1.eq.3) then
5751           if (phii.gt.-dwapi3) then
5752             cosphi=dcos(3*phii)
5753             fac=1.0D0/(1.0D0-cosphi)
5754             etorsi=v1(1,3,3)*fac
5755             etorsi=etorsi+etorsi
5756             etors=etors+etorsi-v1(1,3,3)
5757             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5758             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5759           endif
5760           do j=1,3
5761             v1ij=v1(j+1,itori,itori1)
5762             v2ij=v2(j+1,itori,itori1)
5763             cosphi=dcos(j*phii)
5764             sinphi=dsin(j*phii)
5765             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5766             if (energy_dec) etors_ii=etors_ii+
5767      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5768             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5769           enddo
5770         else
5771           do j=1,nterm_old
5772             v1ij=v1(j,itori,itori1)
5773             v2ij=v2(j,itori,itori1)
5774             cosphi=dcos(j*phii)
5775             sinphi=dsin(j*phii)
5776             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5777             if (energy_dec) etors_ii=etors_ii+
5778      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5779             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5780           enddo
5781         endif
5782         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5783      &        'etor',i,etors_ii
5784         if (lprn)
5785      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5786      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5787      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5788         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5789         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5790       enddo
5791 ! 6/20/98 - dihedral angle constraints
5792       edihcnstr=0.0d0
5793       do i=1,ndih_constr
5794         itori=idih_constr(i)
5795         phii=phi(itori)
5796         difi=phii-phi0(i)
5797         if (difi.gt.drange(i)) then
5798           difi=difi-drange(i)
5799           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5800           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5801         else if (difi.lt.-drange(i)) then
5802           difi=difi+drange(i)
5803           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5804           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5805         endif
5806 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5807 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5808       enddo
5809 !      write (iout,*) 'edihcnstr',edihcnstr
5810       return
5811       end
5812 c------------------------------------------------------------------------------
5813       subroutine etor_d(etors_d)
5814       etors_d=0.0d0
5815       return
5816       end
5817 c----------------------------------------------------------------------------
5818 #else
5819       subroutine etor(etors,edihcnstr)
5820       implicit real*8 (a-h,o-z)
5821       include 'DIMENSIONS'
5822       include 'COMMON.VAR'
5823       include 'COMMON.GEO'
5824       include 'COMMON.LOCAL'
5825       include 'COMMON.TORSION'
5826       include 'COMMON.INTERACT'
5827       include 'COMMON.DERIV'
5828       include 'COMMON.CHAIN'
5829       include 'COMMON.NAMES'
5830       include 'COMMON.IOUNITS'
5831       include 'COMMON.FFIELD'
5832       include 'COMMON.TORCNSTR'
5833       include 'COMMON.CONTROL'
5834       logical lprn
5835 C Set lprn=.true. for debugging
5836       lprn=.false.
5837 c     lprn=.true.
5838       etors=0.0D0
5839       do i=iphi_start,iphi_end
5840         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5841      &       .or. itype(i).eq.ntyp1) cycle
5842         etors_ii=0.0D0
5843          if (iabs(itype(i)).eq.20) then
5844          iblock=2
5845          else
5846          iblock=1
5847          endif
5848         itori=itortyp(itype(i-2))
5849         itori1=itortyp(itype(i-1))
5850         phii=phi(i)
5851         gloci=0.0D0
5852 C Regular cosine and sine terms
5853         do j=1,nterm(itori,itori1,iblock)
5854           v1ij=v1(j,itori,itori1,iblock)
5855           v2ij=v2(j,itori,itori1,iblock)
5856           cosphi=dcos(j*phii)
5857           sinphi=dsin(j*phii)
5858           etors=etors+v1ij*cosphi+v2ij*sinphi
5859           if (energy_dec) etors_ii=etors_ii+
5860      &                v1ij*cosphi+v2ij*sinphi
5861           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5862         enddo
5863 C Lorentz terms
5864 C                         v1
5865 C  E = SUM ----------------------------------- - v1
5866 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5867 C
5868         cosphi=dcos(0.5d0*phii)
5869         sinphi=dsin(0.5d0*phii)
5870         do j=1,nlor(itori,itori1,iblock)
5871           vl1ij=vlor1(j,itori,itori1)
5872           vl2ij=vlor2(j,itori,itori1)
5873           vl3ij=vlor3(j,itori,itori1)
5874           pom=vl2ij*cosphi+vl3ij*sinphi
5875           pom1=1.0d0/(pom*pom+1.0d0)
5876           etors=etors+vl1ij*pom1
5877           if (energy_dec) etors_ii=etors_ii+
5878      &                vl1ij*pom1
5879           pom=-pom*pom1*pom1
5880           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5881         enddo
5882 C Subtract the constant term
5883         etors=etors-v0(itori,itori1,iblock)
5884           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5885      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5886         if (lprn)
5887      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5888      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5889      &  (v1(j,itori,itori1,iblock),j=1,6),
5890      &  (v2(j,itori,itori1,iblock),j=1,6)
5891         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5892 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5893       enddo
5894 ! 6/20/98 - dihedral angle constraints
5895       edihcnstr=0.0d0
5896 c      do i=1,ndih_constr
5897       do i=idihconstr_start,idihconstr_end
5898         itori=idih_constr(i)
5899         phii=phi(itori)
5900         difi=pinorm(phii-phi0(i))
5901         if (difi.gt.drange(i)) then
5902           difi=difi-drange(i)
5903           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5904           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5905         else if (difi.lt.-drange(i)) then
5906           difi=difi+drange(i)
5907           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5908           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5909         else
5910           difi=0.0
5911         endif
5912 c        write (iout,*) "gloci", gloc(i-3,icg)
5913 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5914 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5915 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5916       enddo
5917 cd       write (iout,*) 'edihcnstr',edihcnstr
5918       return
5919       end
5920 c----------------------------------------------------------------------------
5921       subroutine etor_d(etors_d)
5922 C 6/23/01 Compute double torsional energy
5923       implicit real*8 (a-h,o-z)
5924       include 'DIMENSIONS'
5925       include 'COMMON.VAR'
5926       include 'COMMON.GEO'
5927       include 'COMMON.LOCAL'
5928       include 'COMMON.TORSION'
5929       include 'COMMON.INTERACT'
5930       include 'COMMON.DERIV'
5931       include 'COMMON.CHAIN'
5932       include 'COMMON.NAMES'
5933       include 'COMMON.IOUNITS'
5934       include 'COMMON.FFIELD'
5935       include 'COMMON.TORCNSTR'
5936       logical lprn
5937 C Set lprn=.true. for debugging
5938       lprn=.false.
5939 c     lprn=.true.
5940       etors_d=0.0D0
5941 c      write(iout,*) "a tu??"
5942       do i=iphid_start,iphid_end
5943         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5944      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5945         itori=itortyp(itype(i-2))
5946         itori1=itortyp(itype(i-1))
5947         itori2=itortyp(itype(i))
5948         phii=phi(i)
5949         phii1=phi(i+1)
5950         gloci1=0.0D0
5951         gloci2=0.0D0
5952         iblock=1
5953         if (iabs(itype(i+1)).eq.20) iblock=2
5954
5955 C Regular cosine and sine terms
5956         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5957           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5958           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5959           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5960           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5961           cosphi1=dcos(j*phii)
5962           sinphi1=dsin(j*phii)
5963           cosphi2=dcos(j*phii1)
5964           sinphi2=dsin(j*phii1)
5965           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5966      &     v2cij*cosphi2+v2sij*sinphi2
5967           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5968           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5969         enddo
5970         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5971           do l=1,k-1
5972             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5973             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5974             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5975             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5976             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5977             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5978             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5979             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5980             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5981      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5982             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5983      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5984             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5985      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5986           enddo
5987         enddo
5988         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5989         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5990       enddo
5991       return
5992       end
5993 #endif
5994 c------------------------------------------------------------------------------
5995       subroutine eback_sc_corr(esccor)
5996 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5997 c        conformational states; temporarily implemented as differences
5998 c        between UNRES torsional potentials (dependent on three types of
5999 c        residues) and the torsional potentials dependent on all 20 types
6000 c        of residues computed from AM1  energy surfaces of terminally-blocked
6001 c        amino-acid residues.
6002       implicit real*8 (a-h,o-z)
6003       include 'DIMENSIONS'
6004       include 'COMMON.VAR'
6005       include 'COMMON.GEO'
6006       include 'COMMON.LOCAL'
6007       include 'COMMON.TORSION'
6008       include 'COMMON.SCCOR'
6009       include 'COMMON.INTERACT'
6010       include 'COMMON.DERIV'
6011       include 'COMMON.CHAIN'
6012       include 'COMMON.NAMES'
6013       include 'COMMON.IOUNITS'
6014       include 'COMMON.FFIELD'
6015       include 'COMMON.CONTROL'
6016       logical lprn
6017 C Set lprn=.true. for debugging
6018       lprn=.false.
6019 c      lprn=.true.
6020 c     write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6021       esccor=0.0D0
6022       do i=itau_start,itau_end
6023         esccor_ii=0.0D0
6024         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6025         isccori=isccortyp(itype(i-2))
6026         isccori1=isccortyp(itype(i-1))
6027         phii=phi(i)
6028 cccc  Added 9 May 2012
6029 cc Tauangle is torsional engle depending on the value of first digit
6030 c(see comment below)
6031 cc Omicron is flat angle depending on the value of first digit
6032 c(see comment below)
6033
6034
6035         do intertyp=1,3 !intertyp
6036 cc Added 09 May 2012 (Adasko)
6037 cc  Intertyp means interaction type of backbone mainchain correlation:
6038 c   1 = SC...Ca...Ca...Ca
6039 c   2 = Ca...Ca...Ca...SC
6040 c   3 = SC...Ca...Ca...SCi
6041         gloci=0.0D0
6042         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6043      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6044      &      (itype(i-1).eq.ntyp1)))
6045      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6046      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6047      &     .or.(itype(i).eq.ntyp1)))
6048      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6049      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6050      &      (itype(i-3).eq.ntyp1)))) cycle
6051         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6052         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6053      & cycle
6054         do j=1,nterm_sccor(isccori,isccori1)
6055           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6056           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6057           cosphi=dcos(j*tauangle(intertyp,i))
6058           sinphi=dsin(j*tauangle(intertyp,i))
6059           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6060           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6061         enddo
6062         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6063 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6064 c     &gloc_sc(intertyp,i-3,icg)
6065         if (lprn)
6066      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6067      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6068      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6069      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6070         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6071        enddo !intertyp
6072       enddo
6073 c        do i=1,nres
6074 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6075 c        enddo
6076       return
6077       end
6078 c----------------------------------------------------------------------------
6079       subroutine multibody(ecorr)
6080 C This subroutine calculates multi-body contributions to energy following
6081 C the idea of Skolnick et al. If side chains I and J make a contact and
6082 C at the same time side chains I+1 and J+1 make a contact, an extra
6083 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6084       implicit real*8 (a-h,o-z)
6085       include 'DIMENSIONS'
6086       include 'COMMON.IOUNITS'
6087       include 'COMMON.DERIV'
6088       include 'COMMON.INTERACT'
6089       include 'COMMON.CONTACTS'
6090       double precision gx(3),gx1(3)
6091       logical lprn
6092
6093 C Set lprn=.true. for debugging
6094       lprn=.false.
6095
6096       if (lprn) then
6097         write (iout,'(a)') 'Contact function values:'
6098         do i=nnt,nct-2
6099           write (iout,'(i2,20(1x,i2,f10.5))')
6100      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6101         enddo
6102       endif
6103       ecorr=0.0D0
6104       do i=nnt,nct
6105         do j=1,3
6106           gradcorr(j,i)=0.0D0
6107           gradxorr(j,i)=0.0D0
6108         enddo
6109       enddo
6110       do i=nnt,nct-2
6111
6112         DO ISHIFT = 3,4
6113
6114         i1=i+ishift
6115         num_conti=num_cont(i)
6116         num_conti1=num_cont(i1)
6117         do jj=1,num_conti
6118           j=jcont(jj,i)
6119           do kk=1,num_conti1
6120             j1=jcont(kk,i1)
6121             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6122 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6123 cd   &                   ' ishift=',ishift
6124 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6125 C The system gains extra energy.
6126               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6127             endif   ! j1==j+-ishift
6128           enddo     ! kk
6129         enddo       ! jj
6130
6131         ENDDO ! ISHIFT
6132
6133       enddo         ! i
6134       return
6135       end
6136 c------------------------------------------------------------------------------
6137       double precision function esccorr(i,j,k,l,jj,kk)
6138       implicit real*8 (a-h,o-z)
6139       include 'DIMENSIONS'
6140       include 'COMMON.IOUNITS'
6141       include 'COMMON.DERIV'
6142       include 'COMMON.INTERACT'
6143       include 'COMMON.CONTACTS'
6144       double precision gx(3),gx1(3)
6145       logical lprn
6146       lprn=.false.
6147       eij=facont(jj,i)
6148       ekl=facont(kk,k)
6149 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6150 C Calculate the multi-body contribution to energy.
6151 C Calculate multi-body contributions to the gradient.
6152 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6153 cd   & k,l,(gacont(m,kk,k),m=1,3)
6154       do m=1,3
6155         gx(m) =ekl*gacont(m,jj,i)
6156         gx1(m)=eij*gacont(m,kk,k)
6157         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6158         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6159         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6160         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6161       enddo
6162       do m=i,j-1
6163         do ll=1,3
6164           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6165         enddo
6166       enddo
6167       do m=k,l-1
6168         do ll=1,3
6169           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6170         enddo
6171       enddo
6172       esccorr=-eij*ekl
6173       return
6174       end
6175 c------------------------------------------------------------------------------
6176       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6177 C This subroutine calculates multi-body contributions to hydrogen-bonding
6178       implicit real*8 (a-h,o-z)
6179       include 'DIMENSIONS'
6180       include 'COMMON.IOUNITS'
6181 #ifdef MPI
6182       include "mpif.h"
6183       parameter (max_cont=maxconts)
6184       parameter (max_dim=26)
6185       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6186       double precision zapas(max_dim,maxconts,max_fg_procs),
6187      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6188       common /przechowalnia/ zapas
6189       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6190      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6191 #endif
6192       include 'COMMON.SETUP'
6193       include 'COMMON.FFIELD'
6194       include 'COMMON.DERIV'
6195       include 'COMMON.INTERACT'
6196       include 'COMMON.CONTACTS'
6197       include 'COMMON.CONTROL'
6198       include 'COMMON.LOCAL'
6199       double precision gx(3),gx1(3),time00
6200       logical lprn,ldone
6201
6202 C Set lprn=.true. for debugging
6203       lprn=.false.
6204 #ifdef MPI
6205       n_corr=0
6206       n_corr1=0
6207       if (nfgtasks.le.1) goto 30
6208       if (lprn) then
6209         write (iout,'(a)') 'Contact function values before RECEIVE:'
6210         do i=nnt,nct-2
6211           write (iout,'(2i3,50(1x,i2,f5.2))')
6212      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6213      &    j=1,num_cont_hb(i))
6214         enddo
6215       endif
6216       call flush(iout)
6217       do i=1,ntask_cont_from
6218         ncont_recv(i)=0
6219       enddo
6220       do i=1,ntask_cont_to
6221         ncont_sent(i)=0
6222       enddo
6223 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6224 c     & ntask_cont_to
6225 C Make the list of contacts to send to send to other procesors
6226 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6227 c      call flush(iout)
6228       do i=iturn3_start,iturn3_end
6229 c        write (iout,*) "make contact list turn3",i," num_cont",
6230 c     &    num_cont_hb(i)
6231         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6232       enddo
6233       do i=iturn4_start,iturn4_end
6234 c        write (iout,*) "make contact list turn4",i," num_cont",
6235 c     &   num_cont_hb(i)
6236         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6237       enddo
6238       do ii=1,nat_sent
6239         i=iat_sent(ii)
6240 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6241 c     &    num_cont_hb(i)
6242         do j=1,num_cont_hb(i)
6243         do k=1,4
6244           jjc=jcont_hb(j,i)
6245           iproc=iint_sent_local(k,jjc,ii)
6246 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6247           if (iproc.gt.0) then
6248             ncont_sent(iproc)=ncont_sent(iproc)+1
6249             nn=ncont_sent(iproc)
6250             zapas(1,nn,iproc)=i
6251             zapas(2,nn,iproc)=jjc
6252             zapas(3,nn,iproc)=facont_hb(j,i)
6253             zapas(4,nn,iproc)=ees0p(j,i)
6254             zapas(5,nn,iproc)=ees0m(j,i)
6255             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6256             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6257             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6258             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6259             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6260             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6261             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6262             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6263             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6264             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6265             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6266             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6267             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6268             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6269             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6270             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6271             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6272             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6273             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6274             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6275             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6276           endif
6277         enddo
6278         enddo
6279       enddo
6280       if (lprn) then
6281       write (iout,*)
6282      &  "Numbers of contacts to be sent to other processors",
6283      &  (ncont_sent(i),i=1,ntask_cont_to)
6284       write (iout,*) "Contacts sent"
6285       do ii=1,ntask_cont_to
6286         nn=ncont_sent(ii)
6287         iproc=itask_cont_to(ii)
6288         write (iout,*) nn," contacts to processor",iproc,
6289      &   " of CONT_TO_COMM group"
6290         do i=1,nn
6291           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6292         enddo
6293       enddo
6294       call flush(iout)
6295       endif
6296       CorrelType=477
6297       CorrelID=fg_rank+1
6298       CorrelType1=478
6299       CorrelID1=nfgtasks+fg_rank+1
6300       ireq=0
6301 C Receive the numbers of needed contacts from other processors
6302       do ii=1,ntask_cont_from
6303         iproc=itask_cont_from(ii)
6304         ireq=ireq+1
6305         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6306      &    FG_COMM,req(ireq),IERR)
6307       enddo
6308 c      write (iout,*) "IRECV ended"
6309 c      call flush(iout)
6310 C Send the number of contacts needed by other processors
6311       do ii=1,ntask_cont_to
6312         iproc=itask_cont_to(ii)
6313         ireq=ireq+1
6314         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6315      &    FG_COMM,req(ireq),IERR)
6316       enddo
6317 c      write (iout,*) "ISEND ended"
6318 c      write (iout,*) "number of requests (nn)",ireq
6319       call flush(iout)
6320       if (ireq.gt.0)
6321      &  call MPI_Waitall(ireq,req,status_array,ierr)
6322 c      write (iout,*)
6323 c     &  "Numbers of contacts to be received from other processors",
6324 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6325 c      call flush(iout)
6326 C Receive contacts
6327       ireq=0
6328       do ii=1,ntask_cont_from
6329         iproc=itask_cont_from(ii)
6330         nn=ncont_recv(ii)
6331 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6332 c     &   " of CONT_TO_COMM group"
6333         call flush(iout)
6334         if (nn.gt.0) then
6335           ireq=ireq+1
6336           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6337      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6338 c          write (iout,*) "ireq,req",ireq,req(ireq)
6339         endif
6340       enddo
6341 C Send the contacts to processors that need them
6342       do ii=1,ntask_cont_to
6343         iproc=itask_cont_to(ii)
6344         nn=ncont_sent(ii)
6345 c        write (iout,*) nn," contacts to processor",iproc,
6346 c     &   " of CONT_TO_COMM group"
6347         if (nn.gt.0) then
6348           ireq=ireq+1
6349           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6350      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6351 c          write (iout,*) "ireq,req",ireq,req(ireq)
6352 c          do i=1,nn
6353 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6354 c          enddo
6355         endif
6356       enddo
6357 c      write (iout,*) "number of requests (contacts)",ireq
6358 c      write (iout,*) "req",(req(i),i=1,4)
6359 c      call flush(iout)
6360       if (ireq.gt.0)
6361      & call MPI_Waitall(ireq,req,status_array,ierr)
6362       do iii=1,ntask_cont_from
6363         iproc=itask_cont_from(iii)
6364         nn=ncont_recv(iii)
6365         if (lprn) then
6366         write (iout,*) "Received",nn," contacts from processor",iproc,
6367      &   " of CONT_FROM_COMM group"
6368         call flush(iout)
6369         do i=1,nn
6370           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6371         enddo
6372         call flush(iout)
6373         endif
6374         do i=1,nn
6375           ii=zapas_recv(1,i,iii)
6376 c Flag the received contacts to prevent double-counting
6377           jj=-zapas_recv(2,i,iii)
6378 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6379 c          call flush(iout)
6380           nnn=num_cont_hb(ii)+1
6381           num_cont_hb(ii)=nnn
6382           jcont_hb(nnn,ii)=jj
6383           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6384           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6385           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6386           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6387           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6388           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6389           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6390           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6391           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6392           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6393           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6394           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6395           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6396           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6397           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6398           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6399           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6400           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6401           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6402           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6403           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6404           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6405           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6406           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6407         enddo
6408       enddo
6409       call flush(iout)
6410       if (lprn) then
6411         write (iout,'(a)') 'Contact function values after receive:'
6412         do i=nnt,nct-2
6413           write (iout,'(2i3,50(1x,i3,f5.2))')
6414      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6415      &    j=1,num_cont_hb(i))
6416         enddo
6417         call flush(iout)
6418       endif
6419    30 continue
6420 #endif
6421       if (lprn) then
6422         write (iout,'(a)') 'Contact function values:'
6423         do i=nnt,nct-2
6424           write (iout,'(2i3,50(1x,i3,f5.2))')
6425      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6426      &    j=1,num_cont_hb(i))
6427         enddo
6428       endif
6429       ecorr=0.0D0
6430 C Remove the loop below after debugging !!!
6431       do i=nnt,nct
6432         do j=1,3
6433           gradcorr(j,i)=0.0D0
6434           gradxorr(j,i)=0.0D0
6435         enddo
6436       enddo
6437 C Calculate the local-electrostatic correlation terms
6438       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6439         i1=i+1
6440         num_conti=num_cont_hb(i)
6441         num_conti1=num_cont_hb(i+1)
6442         do jj=1,num_conti
6443           j=jcont_hb(jj,i)
6444           jp=iabs(j)
6445           do kk=1,num_conti1
6446             j1=jcont_hb(kk,i1)
6447             jp1=iabs(j1)
6448 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6449 c     &         ' jj=',jj,' kk=',kk
6450             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6451      &          .or. j.lt.0 .and. j1.gt.0) .and.
6452      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6453 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6454 C The system gains extra energy.
6455               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6456               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6457      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6458               n_corr=n_corr+1
6459             else if (j1.eq.j) then
6460 C Contacts I-J and I-(J+1) occur simultaneously.
6461 C The system loses extra energy.
6462 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6463             endif
6464           enddo ! kk
6465           do kk=1,num_conti
6466             j1=jcont_hb(kk,i)
6467 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6468 c    &         ' jj=',jj,' kk=',kk
6469             if (j1.eq.j+1) then
6470 C Contacts I-J and (I+1)-J occur simultaneously.
6471 C The system loses extra energy.
6472 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6473             endif ! j1==j+1
6474           enddo ! kk
6475         enddo ! jj
6476       enddo ! i
6477       return
6478       end
6479 c------------------------------------------------------------------------------
6480       subroutine add_hb_contact(ii,jj,itask)
6481       implicit real*8 (a-h,o-z)
6482       include "DIMENSIONS"
6483       include "COMMON.IOUNITS"
6484       integer max_cont
6485       integer max_dim
6486       parameter (max_cont=maxconts)
6487       parameter (max_dim=26)
6488       include "COMMON.CONTACTS"
6489       double precision zapas(max_dim,maxconts,max_fg_procs),
6490      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6491       common /przechowalnia/ zapas
6492       integer i,j,ii,jj,iproc,itask(4),nn
6493 c      write (iout,*) "itask",itask
6494       do i=1,2
6495         iproc=itask(i)
6496         if (iproc.gt.0) then
6497           do j=1,num_cont_hb(ii)
6498             jjc=jcont_hb(j,ii)
6499 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6500             if (jjc.eq.jj) then
6501               ncont_sent(iproc)=ncont_sent(iproc)+1
6502               nn=ncont_sent(iproc)
6503               zapas(1,nn,iproc)=ii
6504               zapas(2,nn,iproc)=jjc
6505               zapas(3,nn,iproc)=facont_hb(j,ii)
6506               zapas(4,nn,iproc)=ees0p(j,ii)
6507               zapas(5,nn,iproc)=ees0m(j,ii)
6508               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6509               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6510               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6511               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6512               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6513               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6514               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6515               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6516               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6517               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6518               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6519               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6520               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6521               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6522               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6523               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6524               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6525               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6526               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6527               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6528               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6529               exit
6530             endif
6531           enddo
6532         endif
6533       enddo
6534       return
6535       end
6536 c------------------------------------------------------------------------------
6537       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6538      &  n_corr1)
6539 C This subroutine calculates multi-body contributions to hydrogen-bonding
6540       implicit real*8 (a-h,o-z)
6541       include 'DIMENSIONS'
6542       include 'COMMON.IOUNITS'
6543 #ifdef MPI
6544       include "mpif.h"
6545       parameter (max_cont=maxconts)
6546       parameter (max_dim=70)
6547       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6548       double precision zapas(max_dim,maxconts,max_fg_procs),
6549      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6550       common /przechowalnia/ zapas
6551       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6552      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6553 #endif
6554       include 'COMMON.SETUP'
6555       include 'COMMON.FFIELD'
6556       include 'COMMON.DERIV'
6557       include 'COMMON.LOCAL'
6558       include 'COMMON.INTERACT'
6559       include 'COMMON.CONTACTS'
6560       include 'COMMON.CHAIN'
6561       include 'COMMON.CONTROL'
6562       double precision gx(3),gx1(3)
6563       integer num_cont_hb_old(maxres)
6564       logical lprn,ldone
6565       double precision eello4,eello5,eelo6,eello_turn6
6566       external eello4,eello5,eello6,eello_turn6
6567 C Set lprn=.true. for debugging
6568       lprn=.false.
6569       eturn6=0.0d0
6570 #ifdef MPI
6571       do i=1,nres
6572         num_cont_hb_old(i)=num_cont_hb(i)
6573       enddo
6574       n_corr=0
6575       n_corr1=0
6576       if (nfgtasks.le.1) goto 30
6577       if (lprn) then
6578         write (iout,'(a)') 'Contact function values before RECEIVE:'
6579         do i=nnt,nct-2
6580           write (iout,'(2i3,50(1x,i2,f5.2))')
6581      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6582      &    j=1,num_cont_hb(i))
6583         enddo
6584       endif
6585       call flush(iout)
6586       do i=1,ntask_cont_from
6587         ncont_recv(i)=0
6588       enddo
6589       do i=1,ntask_cont_to
6590         ncont_sent(i)=0
6591       enddo
6592 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6593 c     & ntask_cont_to
6594 C Make the list of contacts to send to send to other procesors
6595       do i=iturn3_start,iturn3_end
6596 c        write (iout,*) "make contact list turn3",i," num_cont",
6597 c     &    num_cont_hb(i)
6598         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6599       enddo
6600       do i=iturn4_start,iturn4_end
6601 c        write (iout,*) "make contact list turn4",i," num_cont",
6602 c     &   num_cont_hb(i)
6603         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6604       enddo
6605       do ii=1,nat_sent
6606         i=iat_sent(ii)
6607 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6608 c     &    num_cont_hb(i)
6609         do j=1,num_cont_hb(i)
6610         do k=1,4
6611           jjc=jcont_hb(j,i)
6612           iproc=iint_sent_local(k,jjc,ii)
6613 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6614           if (iproc.ne.0) then
6615             ncont_sent(iproc)=ncont_sent(iproc)+1
6616             nn=ncont_sent(iproc)
6617             zapas(1,nn,iproc)=i
6618             zapas(2,nn,iproc)=jjc
6619             zapas(3,nn,iproc)=d_cont(j,i)
6620             ind=3
6621             do kk=1,3
6622               ind=ind+1
6623               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6624             enddo
6625             do kk=1,2
6626               do ll=1,2
6627                 ind=ind+1
6628                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6629               enddo
6630             enddo
6631             do jj=1,5
6632               do kk=1,3
6633                 do ll=1,2
6634                   do mm=1,2
6635                     ind=ind+1
6636                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6637                   enddo
6638                 enddo
6639               enddo
6640             enddo
6641           endif
6642         enddo
6643         enddo
6644       enddo
6645       if (lprn) then
6646       write (iout,*)
6647      &  "Numbers of contacts to be sent to other processors",
6648      &  (ncont_sent(i),i=1,ntask_cont_to)
6649       write (iout,*) "Contacts sent"
6650       do ii=1,ntask_cont_to
6651         nn=ncont_sent(ii)
6652         iproc=itask_cont_to(ii)
6653         write (iout,*) nn," contacts to processor",iproc,
6654      &   " of CONT_TO_COMM group"
6655         do i=1,nn
6656           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6657         enddo
6658       enddo
6659       call flush(iout)
6660       endif
6661       CorrelType=477
6662       CorrelID=fg_rank+1
6663       CorrelType1=478
6664       CorrelID1=nfgtasks+fg_rank+1
6665       ireq=0
6666 C Receive the numbers of needed contacts from other processors
6667       do ii=1,ntask_cont_from
6668         iproc=itask_cont_from(ii)
6669         ireq=ireq+1
6670         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6671      &    FG_COMM,req(ireq),IERR)
6672       enddo
6673 c      write (iout,*) "IRECV ended"
6674 c      call flush(iout)
6675 C Send the number of contacts needed by other processors
6676       do ii=1,ntask_cont_to
6677         iproc=itask_cont_to(ii)
6678         ireq=ireq+1
6679         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6680      &    FG_COMM,req(ireq),IERR)
6681       enddo
6682 c      write (iout,*) "ISEND ended"
6683 c      write (iout,*) "number of requests (nn)",ireq
6684       call flush(iout)
6685       if (ireq.gt.0)
6686      &  call MPI_Waitall(ireq,req,status_array,ierr)
6687 c      write (iout,*)
6688 c     &  "Numbers of contacts to be received from other processors",
6689 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6690 c      call flush(iout)
6691 C Receive contacts
6692       ireq=0
6693       do ii=1,ntask_cont_from
6694         iproc=itask_cont_from(ii)
6695         nn=ncont_recv(ii)
6696 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6697 c     &   " of CONT_TO_COMM group"
6698         call flush(iout)
6699         if (nn.gt.0) then
6700           ireq=ireq+1
6701           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6702      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6703 c          write (iout,*) "ireq,req",ireq,req(ireq)
6704         endif
6705       enddo
6706 C Send the contacts to processors that need them
6707       do ii=1,ntask_cont_to
6708         iproc=itask_cont_to(ii)
6709         nn=ncont_sent(ii)
6710 c        write (iout,*) nn," contacts to processor",iproc,
6711 c     &   " of CONT_TO_COMM group"
6712         if (nn.gt.0) then
6713           ireq=ireq+1
6714           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6715      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6716 c          write (iout,*) "ireq,req",ireq,req(ireq)
6717 c          do i=1,nn
6718 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6719 c          enddo
6720         endif
6721       enddo
6722 c      write (iout,*) "number of requests (contacts)",ireq
6723 c      write (iout,*) "req",(req(i),i=1,4)
6724 c      call flush(iout)
6725       if (ireq.gt.0)
6726      & call MPI_Waitall(ireq,req,status_array,ierr)
6727       do iii=1,ntask_cont_from
6728         iproc=itask_cont_from(iii)
6729         nn=ncont_recv(iii)
6730         if (lprn) then
6731         write (iout,*) "Received",nn," contacts from processor",iproc,
6732      &   " of CONT_FROM_COMM group"
6733         call flush(iout)
6734         do i=1,nn
6735           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6736         enddo
6737         call flush(iout)
6738         endif
6739         do i=1,nn
6740           ii=zapas_recv(1,i,iii)
6741 c Flag the received contacts to prevent double-counting
6742           jj=-zapas_recv(2,i,iii)
6743 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6744 c          call flush(iout)
6745           nnn=num_cont_hb(ii)+1
6746           num_cont_hb(ii)=nnn
6747           jcont_hb(nnn,ii)=jj
6748           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6749           ind=3
6750           do kk=1,3
6751             ind=ind+1
6752             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6753           enddo
6754           do kk=1,2
6755             do ll=1,2
6756               ind=ind+1
6757               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6758             enddo
6759           enddo
6760           do jj=1,5
6761             do kk=1,3
6762               do ll=1,2
6763                 do mm=1,2
6764                   ind=ind+1
6765                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6766                 enddo
6767               enddo
6768             enddo
6769           enddo
6770         enddo
6771       enddo
6772       call flush(iout)
6773       if (lprn) then
6774         write (iout,'(a)') 'Contact function values after receive:'
6775         do i=nnt,nct-2
6776           write (iout,'(2i3,50(1x,i3,5f6.3))')
6777      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6778      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6779         enddo
6780         call flush(iout)
6781       endif
6782    30 continue
6783 #endif
6784       if (lprn) then
6785         write (iout,'(a)') 'Contact function values:'
6786         do i=nnt,nct-2
6787           write (iout,'(2i3,50(1x,i2,5f6.3))')
6788      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6789      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6790         enddo
6791       endif
6792       ecorr=0.0D0
6793       ecorr5=0.0d0
6794       ecorr6=0.0d0
6795 C Remove the loop below after debugging !!!
6796       do i=nnt,nct
6797         do j=1,3
6798           gradcorr(j,i)=0.0D0
6799           gradxorr(j,i)=0.0D0
6800         enddo
6801       enddo
6802 C Calculate the dipole-dipole interaction energies
6803       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6804       do i=iatel_s,iatel_e+1
6805         num_conti=num_cont_hb(i)
6806         do jj=1,num_conti
6807           j=jcont_hb(jj,i)
6808 #ifdef MOMENT
6809           call dipole(i,j,jj)
6810 #endif
6811         enddo
6812       enddo
6813       endif
6814 C Calculate the local-electrostatic correlation terms
6815 c                write (iout,*) "gradcorr5 in eello5 before loop"
6816 c                do iii=1,nres
6817 c                  write (iout,'(i5,3f10.5)')
6818 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6819 c                enddo
6820       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6821 c        write (iout,*) "corr loop i",i
6822         i1=i+1
6823         num_conti=num_cont_hb(i)
6824         num_conti1=num_cont_hb(i+1)
6825         do jj=1,num_conti
6826           j=jcont_hb(jj,i)
6827           jp=iabs(j)
6828           do kk=1,num_conti1
6829             j1=jcont_hb(kk,i1)
6830             jp1=iabs(j1)
6831 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6832 c     &         ' jj=',jj,' kk=',kk
6833 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6834             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6835      &          .or. j.lt.0 .and. j1.gt.0) .and.
6836      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6837 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6838 C The system gains extra energy.
6839               n_corr=n_corr+1
6840               sqd1=dsqrt(d_cont(jj,i))
6841               sqd2=dsqrt(d_cont(kk,i1))
6842               sred_geom = sqd1*sqd2
6843               IF (sred_geom.lt.cutoff_corr) THEN
6844                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6845      &            ekont,fprimcont)
6846 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6847 cd     &         ' jj=',jj,' kk=',kk
6848                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6849                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6850                 do l=1,3
6851                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6852                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6853                 enddo
6854                 n_corr1=n_corr1+1
6855 cd               write (iout,*) 'sred_geom=',sred_geom,
6856 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6857 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6858 cd               write (iout,*) "g_contij",g_contij
6859 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6860 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6861                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6862                 if (wcorr4.gt.0.0d0)
6863      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6864                   if (energy_dec.and.wcorr4.gt.0.0d0)
6865      1                 write (iout,'(a6,4i5,0pf7.3)')
6866      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6867 c                write (iout,*) "gradcorr5 before eello5"
6868 c                do iii=1,nres
6869 c                  write (iout,'(i5,3f10.5)')
6870 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6871 c                enddo
6872                 if (wcorr5.gt.0.0d0)
6873      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6874 c                write (iout,*) "gradcorr5 after eello5"
6875 c                do iii=1,nres
6876 c                  write (iout,'(i5,3f10.5)')
6877 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6878 c                enddo
6879                   if (energy_dec.and.wcorr5.gt.0.0d0)
6880      1                 write (iout,'(a6,4i5,0pf7.3)')
6881      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6882 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6883 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6884                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6885      &               .or. wturn6.eq.0.0d0))then
6886 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6887                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6888                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6889      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6890 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6891 cd     &            'ecorr6=',ecorr6
6892 cd                write (iout,'(4e15.5)') sred_geom,
6893 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6894 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6895 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6896                 else if (wturn6.gt.0.0d0
6897      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6898 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6899                   eturn6=eturn6+eello_turn6(i,jj,kk)
6900                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6901      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6902 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6903                 endif
6904               ENDIF
6905 1111          continue
6906             endif
6907           enddo ! kk
6908         enddo ! jj
6909       enddo ! i
6910       do i=1,nres
6911         num_cont_hb(i)=num_cont_hb_old(i)
6912       enddo
6913 c                write (iout,*) "gradcorr5 in eello5"
6914 c                do iii=1,nres
6915 c                  write (iout,'(i5,3f10.5)')
6916 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6917 c                enddo
6918       return
6919       end
6920 c------------------------------------------------------------------------------
6921       subroutine add_hb_contact_eello(ii,jj,itask)
6922       implicit real*8 (a-h,o-z)
6923       include "DIMENSIONS"
6924       include "COMMON.IOUNITS"
6925       integer max_cont
6926       integer max_dim
6927       parameter (max_cont=maxconts)
6928       parameter (max_dim=70)
6929       include "COMMON.CONTACTS"
6930       double precision zapas(max_dim,maxconts,max_fg_procs),
6931      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6932       common /przechowalnia/ zapas
6933       integer i,j,ii,jj,iproc,itask(4),nn
6934 c      write (iout,*) "itask",itask
6935       do i=1,2
6936         iproc=itask(i)
6937         if (iproc.gt.0) then
6938           do j=1,num_cont_hb(ii)
6939             jjc=jcont_hb(j,ii)
6940 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6941             if (jjc.eq.jj) then
6942               ncont_sent(iproc)=ncont_sent(iproc)+1
6943               nn=ncont_sent(iproc)
6944               zapas(1,nn,iproc)=ii
6945               zapas(2,nn,iproc)=jjc
6946               zapas(3,nn,iproc)=d_cont(j,ii)
6947               ind=3
6948               do kk=1,3
6949                 ind=ind+1
6950                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6951               enddo
6952               do kk=1,2
6953                 do ll=1,2
6954                   ind=ind+1
6955                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6956                 enddo
6957               enddo
6958               do jj=1,5
6959                 do kk=1,3
6960                   do ll=1,2
6961                     do mm=1,2
6962                       ind=ind+1
6963                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6964                     enddo
6965                   enddo
6966                 enddo
6967               enddo
6968               exit
6969             endif
6970           enddo
6971         endif
6972       enddo
6973       return
6974       end
6975 c------------------------------------------------------------------------------
6976       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6977       implicit real*8 (a-h,o-z)
6978       include 'DIMENSIONS'
6979       include 'COMMON.IOUNITS'
6980       include 'COMMON.DERIV'
6981       include 'COMMON.INTERACT'
6982       include 'COMMON.CONTACTS'
6983       double precision gx(3),gx1(3)
6984       logical lprn
6985       lprn=.false.
6986       eij=facont_hb(jj,i)
6987       ekl=facont_hb(kk,k)
6988       ees0pij=ees0p(jj,i)
6989       ees0pkl=ees0p(kk,k)
6990       ees0mij=ees0m(jj,i)
6991       ees0mkl=ees0m(kk,k)
6992       ekont=eij*ekl
6993       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6994 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6995 C Following 4 lines for diagnostics.
6996 cd    ees0pkl=0.0D0
6997 cd    ees0pij=1.0D0
6998 cd    ees0mkl=0.0D0
6999 cd    ees0mij=1.0D0
7000 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
7001 c     & 'Contacts ',i,j,
7002 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7003 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7004 c     & 'gradcorr_long'
7005 C Calculate the multi-body contribution to energy.
7006 c      ecorr=ecorr+ekont*ees
7007 C Calculate multi-body contributions to the gradient.
7008       coeffpees0pij=coeffp*ees0pij
7009       coeffmees0mij=coeffm*ees0mij
7010       coeffpees0pkl=coeffp*ees0pkl
7011       coeffmees0mkl=coeffm*ees0mkl
7012       do ll=1,3
7013 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7014         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7015      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7016      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7017         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7018      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7019      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7020 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7021         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7022      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7023      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7024         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7025      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7026      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7027         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7028      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7029      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7030         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7031         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7032         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7033      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7034      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7035         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7036         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7037 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7038       enddo
7039 c      write (iout,*)
7040 cgrad      do m=i+1,j-1
7041 cgrad        do ll=1,3
7042 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7043 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7044 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7045 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7046 cgrad        enddo
7047 cgrad      enddo
7048 cgrad      do m=k+1,l-1
7049 cgrad        do ll=1,3
7050 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7051 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7052 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7053 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7054 cgrad        enddo
7055 cgrad      enddo
7056 c      write (iout,*) "ehbcorr",ekont*ees
7057       ehbcorr=ekont*ees
7058       return
7059       end
7060 #ifdef MOMENT
7061 C---------------------------------------------------------------------------
7062       subroutine dipole(i,j,jj)
7063       implicit real*8 (a-h,o-z)
7064       include 'DIMENSIONS'
7065       include 'COMMON.IOUNITS'
7066       include 'COMMON.CHAIN'
7067       include 'COMMON.FFIELD'
7068       include 'COMMON.DERIV'
7069       include 'COMMON.INTERACT'
7070       include 'COMMON.CONTACTS'
7071       include 'COMMON.TORSION'
7072       include 'COMMON.VAR'
7073       include 'COMMON.GEO'
7074       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7075      &  auxmat(2,2)
7076       iti1 = itortyp(itype(i+1))
7077       if (j.lt.nres-1) then
7078         itj1 = itortyp(itype(j+1))
7079       else
7080         itj1=ntortyp+1
7081       endif
7082       do iii=1,2
7083         dipi(iii,1)=Ub2(iii,i)
7084         dipderi(iii)=Ub2der(iii,i)
7085         dipi(iii,2)=b1(iii,iti1)
7086         dipj(iii,1)=Ub2(iii,j)
7087         dipderj(iii)=Ub2der(iii,j)
7088         dipj(iii,2)=b1(iii,itj1)
7089       enddo
7090       kkk=0
7091       do iii=1,2
7092         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7093         do jjj=1,2
7094           kkk=kkk+1
7095           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7096         enddo
7097       enddo
7098       do kkk=1,5
7099         do lll=1,3
7100           mmm=0
7101           do iii=1,2
7102             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7103      &        auxvec(1))
7104             do jjj=1,2
7105               mmm=mmm+1
7106               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7107             enddo
7108           enddo
7109         enddo
7110       enddo
7111       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7112       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7113       do iii=1,2
7114         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7115       enddo
7116       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7117       do iii=1,2
7118         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7119       enddo
7120       return
7121       end
7122 #endif
7123 C---------------------------------------------------------------------------
7124       subroutine calc_eello(i,j,k,l,jj,kk)
7125 C
7126 C This subroutine computes matrices and vectors needed to calculate
7127 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7128 C
7129       implicit real*8 (a-h,o-z)
7130       include 'DIMENSIONS'
7131       include 'COMMON.IOUNITS'
7132       include 'COMMON.CHAIN'
7133       include 'COMMON.DERIV'
7134       include 'COMMON.INTERACT'
7135       include 'COMMON.CONTACTS'
7136       include 'COMMON.TORSION'
7137       include 'COMMON.VAR'
7138       include 'COMMON.GEO'
7139       include 'COMMON.FFIELD'
7140       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7141      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7142       logical lprn
7143       common /kutas/ lprn
7144 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7145 cd     & ' jj=',jj,' kk=',kk
7146 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7147 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7148 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7149       do iii=1,2
7150         do jjj=1,2
7151           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7152           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7153         enddo
7154       enddo
7155       call transpose2(aa1(1,1),aa1t(1,1))
7156       call transpose2(aa2(1,1),aa2t(1,1))
7157       do kkk=1,5
7158         do lll=1,3
7159           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7160      &      aa1tder(1,1,lll,kkk))
7161           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7162      &      aa2tder(1,1,lll,kkk))
7163         enddo
7164       enddo
7165       if (l.eq.j+1) then
7166 C parallel orientation of the two CA-CA-CA frames.
7167         if (i.gt.1) then
7168           iti=itortyp(itype(i))
7169         else
7170           iti=ntortyp+1
7171         endif
7172         itk1=itortyp(itype(k+1))
7173         itj=itortyp(itype(j))
7174         if (l.lt.nres-1) then
7175           itl1=itortyp(itype(l+1))
7176         else
7177           itl1=ntortyp+1
7178         endif
7179 C A1 kernel(j+1) A2T
7180 cd        do iii=1,2
7181 cd          write (iout,'(3f10.5,5x,3f10.5)')
7182 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7183 cd        enddo
7184         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7185      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7186      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7187 C Following matrices are needed only for 6-th order cumulants
7188         IF (wcorr6.gt.0.0d0) THEN
7189         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7190      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7191      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7192         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7193      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7194      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7195      &   ADtEAderx(1,1,1,1,1,1))
7196         lprn=.false.
7197         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7198      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7199      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7200      &   ADtEA1derx(1,1,1,1,1,1))
7201         ENDIF
7202 C End 6-th order cumulants
7203 cd        lprn=.false.
7204 cd        if (lprn) then
7205 cd        write (2,*) 'In calc_eello6'
7206 cd        do iii=1,2
7207 cd          write (2,*) 'iii=',iii
7208 cd          do kkk=1,5
7209 cd            write (2,*) 'kkk=',kkk
7210 cd            do jjj=1,2
7211 cd              write (2,'(3(2f10.5),5x)')
7212 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7213 cd            enddo
7214 cd          enddo
7215 cd        enddo
7216 cd        endif
7217         call transpose2(EUgder(1,1,k),auxmat(1,1))
7218         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7219         call transpose2(EUg(1,1,k),auxmat(1,1))
7220         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7221         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7222         do iii=1,2
7223           do kkk=1,5
7224             do lll=1,3
7225               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7226      &          EAEAderx(1,1,lll,kkk,iii,1))
7227             enddo
7228           enddo
7229         enddo
7230 C A1T kernel(i+1) A2
7231         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7232      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7233      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7234 C Following matrices are needed only for 6-th order cumulants
7235         IF (wcorr6.gt.0.0d0) THEN
7236         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7237      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7238      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7239         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7240      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7241      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7242      &   ADtEAderx(1,1,1,1,1,2))
7243         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7244      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7245      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7246      &   ADtEA1derx(1,1,1,1,1,2))
7247         ENDIF
7248 C End 6-th order cumulants
7249         call transpose2(EUgder(1,1,l),auxmat(1,1))
7250         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7251         call transpose2(EUg(1,1,l),auxmat(1,1))
7252         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7253         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7254         do iii=1,2
7255           do kkk=1,5
7256             do lll=1,3
7257               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7258      &          EAEAderx(1,1,lll,kkk,iii,2))
7259             enddo
7260           enddo
7261         enddo
7262 C AEAb1 and AEAb2
7263 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7264 C They are needed only when the fifth- or the sixth-order cumulants are
7265 C indluded.
7266         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7267         call transpose2(AEA(1,1,1),auxmat(1,1))
7268         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7269         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7270         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7271         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7272         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7273         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7274         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7275         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7276         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7277         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7278         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7279         call transpose2(AEA(1,1,2),auxmat(1,1))
7280         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7281         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7282         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7283         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7284         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7285         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7286         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7287         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7288         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7289         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7290         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7291 C Calculate the Cartesian derivatives of the vectors.
7292         do iii=1,2
7293           do kkk=1,5
7294             do lll=1,3
7295               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7296               call matvec2(auxmat(1,1),b1(1,iti),
7297      &          AEAb1derx(1,lll,kkk,iii,1,1))
7298               call matvec2(auxmat(1,1),Ub2(1,i),
7299      &          AEAb2derx(1,lll,kkk,iii,1,1))
7300               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7301      &          AEAb1derx(1,lll,kkk,iii,2,1))
7302               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7303      &          AEAb2derx(1,lll,kkk,iii,2,1))
7304               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7305               call matvec2(auxmat(1,1),b1(1,itj),
7306      &          AEAb1derx(1,lll,kkk,iii,1,2))
7307               call matvec2(auxmat(1,1),Ub2(1,j),
7308      &          AEAb2derx(1,lll,kkk,iii,1,2))
7309               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7310      &          AEAb1derx(1,lll,kkk,iii,2,2))
7311               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7312      &          AEAb2derx(1,lll,kkk,iii,2,2))
7313             enddo
7314           enddo
7315         enddo
7316         ENDIF
7317 C End vectors
7318       else
7319 C Antiparallel orientation of the two CA-CA-CA frames.
7320         if (i.gt.1) then
7321           iti=itortyp(itype(i))
7322         else
7323           iti=ntortyp+1
7324         endif
7325         itk1=itortyp(itype(k+1))
7326         itl=itortyp(itype(l))
7327         itj=itortyp(itype(j))
7328         if (j.lt.nres-1) then
7329           itj1=itortyp(itype(j+1))
7330         else
7331           itj1=ntortyp+1
7332         endif
7333 C A2 kernel(j-1)T A1T
7334         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7335      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7336      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7337 C Following matrices are needed only for 6-th order cumulants
7338         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7339      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7340         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7341      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7342      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7343         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7344      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7345      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7346      &   ADtEAderx(1,1,1,1,1,1))
7347         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7348      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7349      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7350      &   ADtEA1derx(1,1,1,1,1,1))
7351         ENDIF
7352 C End 6-th order cumulants
7353         call transpose2(EUgder(1,1,k),auxmat(1,1))
7354         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7355         call transpose2(EUg(1,1,k),auxmat(1,1))
7356         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7357         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7358         do iii=1,2
7359           do kkk=1,5
7360             do lll=1,3
7361               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7362      &          EAEAderx(1,1,lll,kkk,iii,1))
7363             enddo
7364           enddo
7365         enddo
7366 C A2T kernel(i+1)T A1
7367         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7368      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7369      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7370 C Following matrices are needed only for 6-th order cumulants
7371         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7372      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7373         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7374      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7375      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7376         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7377      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7378      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7379      &   ADtEAderx(1,1,1,1,1,2))
7380         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7381      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7382      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7383      &   ADtEA1derx(1,1,1,1,1,2))
7384         ENDIF
7385 C End 6-th order cumulants
7386         call transpose2(EUgder(1,1,j),auxmat(1,1))
7387         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7388         call transpose2(EUg(1,1,j),auxmat(1,1))
7389         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7390         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7391         do iii=1,2
7392           do kkk=1,5
7393             do lll=1,3
7394               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7395      &          EAEAderx(1,1,lll,kkk,iii,2))
7396             enddo
7397           enddo
7398         enddo
7399 C AEAb1 and AEAb2
7400 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7401 C They are needed only when the fifth- or the sixth-order cumulants are
7402 C indluded.
7403         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7404      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7405         call transpose2(AEA(1,1,1),auxmat(1,1))
7406         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7407         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7408         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7409         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7410         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7411         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7412         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7413         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7414         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7415         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7416         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7417         call transpose2(AEA(1,1,2),auxmat(1,1))
7418         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7419         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7420         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7421         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7422         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7423         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7424         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7425         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7426         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7427         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7428         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7429 C Calculate the Cartesian derivatives of the vectors.
7430         do iii=1,2
7431           do kkk=1,5
7432             do lll=1,3
7433               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7434               call matvec2(auxmat(1,1),b1(1,iti),
7435      &          AEAb1derx(1,lll,kkk,iii,1,1))
7436               call matvec2(auxmat(1,1),Ub2(1,i),
7437      &          AEAb2derx(1,lll,kkk,iii,1,1))
7438               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7439      &          AEAb1derx(1,lll,kkk,iii,2,1))
7440               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7441      &          AEAb2derx(1,lll,kkk,iii,2,1))
7442               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7443               call matvec2(auxmat(1,1),b1(1,itl),
7444      &          AEAb1derx(1,lll,kkk,iii,1,2))
7445               call matvec2(auxmat(1,1),Ub2(1,l),
7446      &          AEAb2derx(1,lll,kkk,iii,1,2))
7447               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7448      &          AEAb1derx(1,lll,kkk,iii,2,2))
7449               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7450      &          AEAb2derx(1,lll,kkk,iii,2,2))
7451             enddo
7452           enddo
7453         enddo
7454         ENDIF
7455 C End vectors
7456       endif
7457       return
7458       end
7459 C---------------------------------------------------------------------------
7460       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7461      &  KK,KKderg,AKA,AKAderg,AKAderx)
7462       implicit none
7463       integer nderg
7464       logical transp
7465       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7466      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7467      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7468       integer iii,kkk,lll
7469       integer jjj,mmm
7470       logical lprn
7471       common /kutas/ lprn
7472       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7473       do iii=1,nderg
7474         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7475      &    AKAderg(1,1,iii))
7476       enddo
7477 cd      if (lprn) write (2,*) 'In kernel'
7478       do kkk=1,5
7479 cd        if (lprn) write (2,*) 'kkk=',kkk
7480         do lll=1,3
7481           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7482      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7483 cd          if (lprn) then
7484 cd            write (2,*) 'lll=',lll
7485 cd            write (2,*) 'iii=1'
7486 cd            do jjj=1,2
7487 cd              write (2,'(3(2f10.5),5x)')
7488 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7489 cd            enddo
7490 cd          endif
7491           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7492      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7493 cd          if (lprn) then
7494 cd            write (2,*) 'lll=',lll
7495 cd            write (2,*) 'iii=2'
7496 cd            do jjj=1,2
7497 cd              write (2,'(3(2f10.5),5x)')
7498 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7499 cd            enddo
7500 cd          endif
7501         enddo
7502       enddo
7503       return
7504       end
7505 C---------------------------------------------------------------------------
7506       double precision function eello4(i,j,k,l,jj,kk)
7507       implicit real*8 (a-h,o-z)
7508       include 'DIMENSIONS'
7509       include 'COMMON.IOUNITS'
7510       include 'COMMON.CHAIN'
7511       include 'COMMON.DERIV'
7512       include 'COMMON.INTERACT'
7513       include 'COMMON.CONTACTS'
7514       include 'COMMON.TORSION'
7515       include 'COMMON.VAR'
7516       include 'COMMON.GEO'
7517       double precision pizda(2,2),ggg1(3),ggg2(3)
7518 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7519 cd        eello4=0.0d0
7520 cd        return
7521 cd      endif
7522 cd      print *,'eello4:',i,j,k,l,jj,kk
7523 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7524 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7525 cold      eij=facont_hb(jj,i)
7526 cold      ekl=facont_hb(kk,k)
7527 cold      ekont=eij*ekl
7528       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7529 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7530       gcorr_loc(k-1)=gcorr_loc(k-1)
7531      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7532       if (l.eq.j+1) then
7533         gcorr_loc(l-1)=gcorr_loc(l-1)
7534      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7535       else
7536         gcorr_loc(j-1)=gcorr_loc(j-1)
7537      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7538       endif
7539       do iii=1,2
7540         do kkk=1,5
7541           do lll=1,3
7542             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7543      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7544 cd            derx(lll,kkk,iii)=0.0d0
7545           enddo
7546         enddo
7547       enddo
7548 cd      gcorr_loc(l-1)=0.0d0
7549 cd      gcorr_loc(j-1)=0.0d0
7550 cd      gcorr_loc(k-1)=0.0d0
7551 cd      eel4=1.0d0
7552 cd      write (iout,*)'Contacts have occurred for peptide groups',
7553 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7554 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7555       if (j.lt.nres-1) then
7556         j1=j+1
7557         j2=j-1
7558       else
7559         j1=j-1
7560         j2=j-2
7561       endif
7562       if (l.lt.nres-1) then
7563         l1=l+1
7564         l2=l-1
7565       else
7566         l1=l-1
7567         l2=l-2
7568       endif
7569       do ll=1,3
7570 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7571 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7572         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7573         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7574 cgrad        ghalf=0.5d0*ggg1(ll)
7575         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7576         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7577         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7578         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7579         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7580         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7581 cgrad        ghalf=0.5d0*ggg2(ll)
7582         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7583         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7584         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7585         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7586         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7587         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7588       enddo
7589 cgrad      do m=i+1,j-1
7590 cgrad        do ll=1,3
7591 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7592 cgrad        enddo
7593 cgrad      enddo
7594 cgrad      do m=k+1,l-1
7595 cgrad        do ll=1,3
7596 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7597 cgrad        enddo
7598 cgrad      enddo
7599 cgrad      do m=i+2,j2
7600 cgrad        do ll=1,3
7601 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7602 cgrad        enddo
7603 cgrad      enddo
7604 cgrad      do m=k+2,l2
7605 cgrad        do ll=1,3
7606 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7607 cgrad        enddo
7608 cgrad      enddo
7609 cd      do iii=1,nres-3
7610 cd        write (2,*) iii,gcorr_loc(iii)
7611 cd      enddo
7612       eello4=ekont*eel4
7613 cd      write (2,*) 'ekont',ekont
7614 cd      write (iout,*) 'eello4',ekont*eel4
7615       return
7616       end
7617 C---------------------------------------------------------------------------
7618       double precision function eello5(i,j,k,l,jj,kk)
7619       implicit real*8 (a-h,o-z)
7620       include 'DIMENSIONS'
7621       include 'COMMON.IOUNITS'
7622       include 'COMMON.CHAIN'
7623       include 'COMMON.DERIV'
7624       include 'COMMON.INTERACT'
7625       include 'COMMON.CONTACTS'
7626       include 'COMMON.TORSION'
7627       include 'COMMON.VAR'
7628       include 'COMMON.GEO'
7629       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7630       double precision ggg1(3),ggg2(3)
7631 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7632 C                                                                              C
7633 C                            Parallel chains                                   C
7634 C                                                                              C
7635 C          o             o                   o             o                   C
7636 C         /l\           / \             \   / \           / \   /              C
7637 C        /   \         /   \             \ /   \         /   \ /               C
7638 C       j| o |l1       | o |              o| o |         | o |o                C
7639 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7640 C      \i/   \         /   \ /             /   \         /   \                 C
7641 C       o    k1             o                                                  C
7642 C         (I)          (II)                (III)          (IV)                 C
7643 C                                                                              C
7644 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7645 C                                                                              C
7646 C                            Antiparallel chains                               C
7647 C                                                                              C
7648 C          o             o                   o             o                   C
7649 C         /j\           / \             \   / \           / \   /              C
7650 C        /   \         /   \             \ /   \         /   \ /               C
7651 C      j1| o |l        | o |              o| o |         | o |o                C
7652 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7653 C      \i/   \         /   \ /             /   \         /   \                 C
7654 C       o     k1            o                                                  C
7655 C         (I)          (II)                (III)          (IV)                 C
7656 C                                                                              C
7657 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7658 C                                                                              C
7659 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7660 C                                                                              C
7661 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7662 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7663 cd        eello5=0.0d0
7664 cd        return
7665 cd      endif
7666 cd      write (iout,*)
7667 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7668 cd     &   ' and',k,l
7669       itk=itortyp(itype(k))
7670       itl=itortyp(itype(l))
7671       itj=itortyp(itype(j))
7672       eello5_1=0.0d0
7673       eello5_2=0.0d0
7674       eello5_3=0.0d0
7675       eello5_4=0.0d0
7676 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7677 cd     &   eel5_3_num,eel5_4_num)
7678       do iii=1,2
7679         do kkk=1,5
7680           do lll=1,3
7681             derx(lll,kkk,iii)=0.0d0
7682           enddo
7683         enddo
7684       enddo
7685 cd      eij=facont_hb(jj,i)
7686 cd      ekl=facont_hb(kk,k)
7687 cd      ekont=eij*ekl
7688 cd      write (iout,*)'Contacts have occurred for peptide groups',
7689 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7690 cd      goto 1111
7691 C Contribution from the graph I.
7692 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7693 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7694       call transpose2(EUg(1,1,k),auxmat(1,1))
7695       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7696       vv(1)=pizda(1,1)-pizda(2,2)
7697       vv(2)=pizda(1,2)+pizda(2,1)
7698       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7699      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7700 C Explicit gradient in virtual-dihedral angles.
7701       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7702      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7703      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7704       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7705       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7706       vv(1)=pizda(1,1)-pizda(2,2)
7707       vv(2)=pizda(1,2)+pizda(2,1)
7708       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7709      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7710      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7711       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7712       vv(1)=pizda(1,1)-pizda(2,2)
7713       vv(2)=pizda(1,2)+pizda(2,1)
7714       if (l.eq.j+1) then
7715         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7716      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7717      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7718       else
7719         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7720      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7721      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7722       endif
7723 C Cartesian gradient
7724       do iii=1,2
7725         do kkk=1,5
7726           do lll=1,3
7727             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7728      &        pizda(1,1))
7729             vv(1)=pizda(1,1)-pizda(2,2)
7730             vv(2)=pizda(1,2)+pizda(2,1)
7731             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7732      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7733      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7734           enddo
7735         enddo
7736       enddo
7737 c      goto 1112
7738 c1111  continue
7739 C Contribution from graph II
7740       call transpose2(EE(1,1,itk),auxmat(1,1))
7741       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7742       vv(1)=pizda(1,1)+pizda(2,2)
7743       vv(2)=pizda(2,1)-pizda(1,2)
7744       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7745      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7746 C Explicit gradient in virtual-dihedral angles.
7747       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7748      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7749       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7750       vv(1)=pizda(1,1)+pizda(2,2)
7751       vv(2)=pizda(2,1)-pizda(1,2)
7752       if (l.eq.j+1) then
7753         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7754      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7755      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7756       else
7757         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7758      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7759      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7760       endif
7761 C Cartesian gradient
7762       do iii=1,2
7763         do kkk=1,5
7764           do lll=1,3
7765             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7766      &        pizda(1,1))
7767             vv(1)=pizda(1,1)+pizda(2,2)
7768             vv(2)=pizda(2,1)-pizda(1,2)
7769             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7770      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7771      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7772           enddo
7773         enddo
7774       enddo
7775 cd      goto 1112
7776 cd1111  continue
7777       if (l.eq.j+1) then
7778 cd        goto 1110
7779 C Parallel orientation
7780 C Contribution from graph III
7781         call transpose2(EUg(1,1,l),auxmat(1,1))
7782         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7783         vv(1)=pizda(1,1)-pizda(2,2)
7784         vv(2)=pizda(1,2)+pizda(2,1)
7785         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7786      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7787 C Explicit gradient in virtual-dihedral angles.
7788         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7789      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7790      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7791         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7792         vv(1)=pizda(1,1)-pizda(2,2)
7793         vv(2)=pizda(1,2)+pizda(2,1)
7794         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7795      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7796      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7797         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7798         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7799         vv(1)=pizda(1,1)-pizda(2,2)
7800         vv(2)=pizda(1,2)+pizda(2,1)
7801         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7802      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7803      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7804 C Cartesian gradient
7805         do iii=1,2
7806           do kkk=1,5
7807             do lll=1,3
7808               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7809      &          pizda(1,1))
7810               vv(1)=pizda(1,1)-pizda(2,2)
7811               vv(2)=pizda(1,2)+pizda(2,1)
7812               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7813      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7814      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7815             enddo
7816           enddo
7817         enddo
7818 cd        goto 1112
7819 C Contribution from graph IV
7820 cd1110    continue
7821         call transpose2(EE(1,1,itl),auxmat(1,1))
7822         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7823         vv(1)=pizda(1,1)+pizda(2,2)
7824         vv(2)=pizda(2,1)-pizda(1,2)
7825         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7826      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7827 C Explicit gradient in virtual-dihedral angles.
7828         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7829      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7830         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7831         vv(1)=pizda(1,1)+pizda(2,2)
7832         vv(2)=pizda(2,1)-pizda(1,2)
7833         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7834      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7835      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7836 C Cartesian gradient
7837         do iii=1,2
7838           do kkk=1,5
7839             do lll=1,3
7840               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7841      &          pizda(1,1))
7842               vv(1)=pizda(1,1)+pizda(2,2)
7843               vv(2)=pizda(2,1)-pizda(1,2)
7844               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7845      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7846      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7847             enddo
7848           enddo
7849         enddo
7850       else
7851 C Antiparallel orientation
7852 C Contribution from graph III
7853 c        goto 1110
7854         call transpose2(EUg(1,1,j),auxmat(1,1))
7855         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7856         vv(1)=pizda(1,1)-pizda(2,2)
7857         vv(2)=pizda(1,2)+pizda(2,1)
7858         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7859      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7860 C Explicit gradient in virtual-dihedral angles.
7861         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7862      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7863      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7864         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7865         vv(1)=pizda(1,1)-pizda(2,2)
7866         vv(2)=pizda(1,2)+pizda(2,1)
7867         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7868      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7869      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7870         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7871         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7872         vv(1)=pizda(1,1)-pizda(2,2)
7873         vv(2)=pizda(1,2)+pizda(2,1)
7874         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7875      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7876      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7877 C Cartesian gradient
7878         do iii=1,2
7879           do kkk=1,5
7880             do lll=1,3
7881               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7882      &          pizda(1,1))
7883               vv(1)=pizda(1,1)-pizda(2,2)
7884               vv(2)=pizda(1,2)+pizda(2,1)
7885               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7886      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7887      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7888             enddo
7889           enddo
7890         enddo
7891 cd        goto 1112
7892 C Contribution from graph IV
7893 1110    continue
7894         call transpose2(EE(1,1,itj),auxmat(1,1))
7895         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7896         vv(1)=pizda(1,1)+pizda(2,2)
7897         vv(2)=pizda(2,1)-pizda(1,2)
7898         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7899      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7900 C Explicit gradient in virtual-dihedral angles.
7901         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7902      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7903         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7904         vv(1)=pizda(1,1)+pizda(2,2)
7905         vv(2)=pizda(2,1)-pizda(1,2)
7906         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7907      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7908      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7909 C Cartesian gradient
7910         do iii=1,2
7911           do kkk=1,5
7912             do lll=1,3
7913               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7914      &          pizda(1,1))
7915               vv(1)=pizda(1,1)+pizda(2,2)
7916               vv(2)=pizda(2,1)-pizda(1,2)
7917               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7918      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7919      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7920             enddo
7921           enddo
7922         enddo
7923       endif
7924 1112  continue
7925       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7926 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7927 cd        write (2,*) 'ijkl',i,j,k,l
7928 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7929 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7930 cd      endif
7931 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7932 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7933 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7934 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7935       if (j.lt.nres-1) then
7936         j1=j+1
7937         j2=j-1
7938       else
7939         j1=j-1
7940         j2=j-2
7941       endif
7942       if (l.lt.nres-1) then
7943         l1=l+1
7944         l2=l-1
7945       else
7946         l1=l-1
7947         l2=l-2
7948       endif
7949 cd      eij=1.0d0
7950 cd      ekl=1.0d0
7951 cd      ekont=1.0d0
7952 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7953 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7954 C        summed up outside the subrouine as for the other subroutines
7955 C        handling long-range interactions. The old code is commented out
7956 C        with "cgrad" to keep track of changes.
7957       do ll=1,3
7958 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7959 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7960         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7961         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7962 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7963 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7964 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7965 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7966 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7967 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7968 c     &   gradcorr5ij,
7969 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7970 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7971 cgrad        ghalf=0.5d0*ggg1(ll)
7972 cd        ghalf=0.0d0
7973         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7974         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7975         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7976         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7977         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7978         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7979 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7980 cgrad        ghalf=0.5d0*ggg2(ll)
7981 cd        ghalf=0.0d0
7982         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7983         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7984         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7985         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7986         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7987         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7988       enddo
7989 cd      goto 1112
7990 cgrad      do m=i+1,j-1
7991 cgrad        do ll=1,3
7992 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7993 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7994 cgrad        enddo
7995 cgrad      enddo
7996 cgrad      do m=k+1,l-1
7997 cgrad        do ll=1,3
7998 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7999 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
8000 cgrad        enddo
8001 cgrad      enddo
8002 c1112  continue
8003 cgrad      do m=i+2,j2
8004 cgrad        do ll=1,3
8005 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8006 cgrad        enddo
8007 cgrad      enddo
8008 cgrad      do m=k+2,l2
8009 cgrad        do ll=1,3
8010 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8011 cgrad        enddo
8012 cgrad      enddo
8013 cd      do iii=1,nres-3
8014 cd        write (2,*) iii,g_corr5_loc(iii)
8015 cd      enddo
8016       eello5=ekont*eel5
8017 cd      write (2,*) 'ekont',ekont
8018 cd      write (iout,*) 'eello5',ekont*eel5
8019       return
8020       end
8021 c--------------------------------------------------------------------------
8022       double precision function eello6(i,j,k,l,jj,kk)
8023       implicit real*8 (a-h,o-z)
8024       include 'DIMENSIONS'
8025       include 'COMMON.IOUNITS'
8026       include 'COMMON.CHAIN'
8027       include 'COMMON.DERIV'
8028       include 'COMMON.INTERACT'
8029       include 'COMMON.CONTACTS'
8030       include 'COMMON.TORSION'
8031       include 'COMMON.VAR'
8032       include 'COMMON.GEO'
8033       include 'COMMON.FFIELD'
8034       double precision ggg1(3),ggg2(3)
8035 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8036 cd        eello6=0.0d0
8037 cd        return
8038 cd      endif
8039 cd      write (iout,*)
8040 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8041 cd     &   ' and',k,l
8042       eello6_1=0.0d0
8043       eello6_2=0.0d0
8044       eello6_3=0.0d0
8045       eello6_4=0.0d0
8046       eello6_5=0.0d0
8047       eello6_6=0.0d0
8048 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8049 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8050       do iii=1,2
8051         do kkk=1,5
8052           do lll=1,3
8053             derx(lll,kkk,iii)=0.0d0
8054           enddo
8055         enddo
8056       enddo
8057 cd      eij=facont_hb(jj,i)
8058 cd      ekl=facont_hb(kk,k)
8059 cd      ekont=eij*ekl
8060 cd      eij=1.0d0
8061 cd      ekl=1.0d0
8062 cd      ekont=1.0d0
8063       if (l.eq.j+1) then
8064         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8065         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8066         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8067         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8068         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8069         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8070       else
8071         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8072         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8073         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8074         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8075         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8076           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8077         else
8078           eello6_5=0.0d0
8079         endif
8080         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8081       endif
8082 C If turn contributions are considered, they will be handled separately.
8083       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8084 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8085 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8086 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8087 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8088 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8089 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8090 cd      goto 1112
8091       if (j.lt.nres-1) then
8092         j1=j+1
8093         j2=j-1
8094       else
8095         j1=j-1
8096         j2=j-2
8097       endif
8098       if (l.lt.nres-1) then
8099         l1=l+1
8100         l2=l-1
8101       else
8102         l1=l-1
8103         l2=l-2
8104       endif
8105       do ll=1,3
8106 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8107 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8108 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8109 cgrad        ghalf=0.5d0*ggg1(ll)
8110 cd        ghalf=0.0d0
8111         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8112         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8113         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8114         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8115         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8116         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8117         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8118         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8119 cgrad        ghalf=0.5d0*ggg2(ll)
8120 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8121 cd        ghalf=0.0d0
8122         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8123         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8124         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8125         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8126         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8127         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8128       enddo
8129 cd      goto 1112
8130 cgrad      do m=i+1,j-1
8131 cgrad        do ll=1,3
8132 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8133 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8134 cgrad        enddo
8135 cgrad      enddo
8136 cgrad      do m=k+1,l-1
8137 cgrad        do ll=1,3
8138 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8139 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8140 cgrad        enddo
8141 cgrad      enddo
8142 cgrad1112  continue
8143 cgrad      do m=i+2,j2
8144 cgrad        do ll=1,3
8145 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8146 cgrad        enddo
8147 cgrad      enddo
8148 cgrad      do m=k+2,l2
8149 cgrad        do ll=1,3
8150 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8151 cgrad        enddo
8152 cgrad      enddo
8153 cd      do iii=1,nres-3
8154 cd        write (2,*) iii,g_corr6_loc(iii)
8155 cd      enddo
8156       eello6=ekont*eel6
8157 cd      write (2,*) 'ekont',ekont
8158 cd      write (iout,*) 'eello6',ekont*eel6
8159       return
8160       end
8161 c--------------------------------------------------------------------------
8162       double precision function eello6_graph1(i,j,k,l,imat,swap)
8163       implicit real*8 (a-h,o-z)
8164       include 'DIMENSIONS'
8165       include 'COMMON.IOUNITS'
8166       include 'COMMON.CHAIN'
8167       include 'COMMON.DERIV'
8168       include 'COMMON.INTERACT'
8169       include 'COMMON.CONTACTS'
8170       include 'COMMON.TORSION'
8171       include 'COMMON.VAR'
8172       include 'COMMON.GEO'
8173       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8174       logical swap
8175       logical lprn
8176       common /kutas/ lprn
8177 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8178 C
8179 C      Parallel       Antiparallel
8180 C
8181 C          o             o
8182 C         /l\           /j\
8183 C        /   \         /   \
8184 C       /| o |         | o |\
8185 C     \ j|/k\|  /   \  |/k\|l /
8186 C      \ /   \ /     \ /   \ /
8187 C       o     o       o     o
8188 C       i             i
8189 C
8190 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8191       itk=itortyp(itype(k))
8192       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8193       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8194       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8195       call transpose2(EUgC(1,1,k),auxmat(1,1))
8196       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8197       vv1(1)=pizda1(1,1)-pizda1(2,2)
8198       vv1(2)=pizda1(1,2)+pizda1(2,1)
8199       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8200       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8201       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8202       s5=scalar2(vv(1),Dtobr2(1,i))
8203 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8204       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8205       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8206      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8207      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8208      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8209      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8210      & +scalar2(vv(1),Dtobr2der(1,i)))
8211       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8212       vv1(1)=pizda1(1,1)-pizda1(2,2)
8213       vv1(2)=pizda1(1,2)+pizda1(2,1)
8214       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8215       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8216       if (l.eq.j+1) then
8217         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8218      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8219      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8220      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8221      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8222       else
8223         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8224      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8225      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8226      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8227      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8228       endif
8229       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8230       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8231       vv1(1)=pizda1(1,1)-pizda1(2,2)
8232       vv1(2)=pizda1(1,2)+pizda1(2,1)
8233       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8234      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8235      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8236      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8237       do iii=1,2
8238         if (swap) then
8239           ind=3-iii
8240         else
8241           ind=iii
8242         endif
8243         do kkk=1,5
8244           do lll=1,3
8245             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8246             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8247             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8248             call transpose2(EUgC(1,1,k),auxmat(1,1))
8249             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8250      &        pizda1(1,1))
8251             vv1(1)=pizda1(1,1)-pizda1(2,2)
8252             vv1(2)=pizda1(1,2)+pizda1(2,1)
8253             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8254             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8255      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8256             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8257      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8258             s5=scalar2(vv(1),Dtobr2(1,i))
8259             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8260           enddo
8261         enddo
8262       enddo
8263       return
8264       end
8265 c----------------------------------------------------------------------------
8266       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8267       implicit real*8 (a-h,o-z)
8268       include 'DIMENSIONS'
8269       include 'COMMON.IOUNITS'
8270       include 'COMMON.CHAIN'
8271       include 'COMMON.DERIV'
8272       include 'COMMON.INTERACT'
8273       include 'COMMON.CONTACTS'
8274       include 'COMMON.TORSION'
8275       include 'COMMON.VAR'
8276       include 'COMMON.GEO'
8277       logical swap
8278       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8279      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8280       logical lprn
8281       common /kutas/ lprn
8282 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8283 C                                                                              C
8284 C      Parallel       Antiparallel                                             C
8285 C                                                                              C
8286 C          o             o                                                     C
8287 C     \   /l\           /j\   /                                                C
8288 C      \ /   \         /   \ /                                                 C
8289 C       o| o |         | o |o                                                  C
8290 C     \ j|/k\|      \  |/k\|l                                                  C
8291 C      \ /   \       \ /   \                                                   C
8292 C       o             o                                                        C
8293 C       i             i                                                        C
8294 C                                                                              C
8295 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8296 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8297 C AL 7/4/01 s1 would occur in the sixth-order moment,
8298 C           but not in a cluster cumulant
8299 #ifdef MOMENT
8300       s1=dip(1,jj,i)*dip(1,kk,k)
8301 #endif
8302       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8303       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8304       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8305       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8306       call transpose2(EUg(1,1,k),auxmat(1,1))
8307       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8308       vv(1)=pizda(1,1)-pizda(2,2)
8309       vv(2)=pizda(1,2)+pizda(2,1)
8310       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8311 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8312 #ifdef MOMENT
8313       eello6_graph2=-(s1+s2+s3+s4)
8314 #else
8315       eello6_graph2=-(s2+s3+s4)
8316 #endif
8317 c      eello6_graph2=-s3
8318 C Derivatives in gamma(i-1)
8319       if (i.gt.1) then
8320 #ifdef MOMENT
8321         s1=dipderg(1,jj,i)*dip(1,kk,k)
8322 #endif
8323         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8324         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8325         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8326         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8327 #ifdef MOMENT
8328         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8329 #else
8330         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8331 #endif
8332 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8333       endif
8334 C Derivatives in gamma(k-1)
8335 #ifdef MOMENT
8336       s1=dip(1,jj,i)*dipderg(1,kk,k)
8337 #endif
8338       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8339       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8340       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8341       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8342       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8343       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8344       vv(1)=pizda(1,1)-pizda(2,2)
8345       vv(2)=pizda(1,2)+pizda(2,1)
8346       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8347 #ifdef MOMENT
8348       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8349 #else
8350       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8351 #endif
8352 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8353 C Derivatives in gamma(j-1) or gamma(l-1)
8354       if (j.gt.1) then
8355 #ifdef MOMENT
8356         s1=dipderg(3,jj,i)*dip(1,kk,k)
8357 #endif
8358         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8359         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8360         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8361         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8362         vv(1)=pizda(1,1)-pizda(2,2)
8363         vv(2)=pizda(1,2)+pizda(2,1)
8364         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8365 #ifdef MOMENT
8366         if (swap) then
8367           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8368         else
8369           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8370         endif
8371 #endif
8372         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8373 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8374       endif
8375 C Derivatives in gamma(l-1) or gamma(j-1)
8376       if (l.gt.1) then
8377 #ifdef MOMENT
8378         s1=dip(1,jj,i)*dipderg(3,kk,k)
8379 #endif
8380         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8381         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8382         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8383         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8384         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8385         vv(1)=pizda(1,1)-pizda(2,2)
8386         vv(2)=pizda(1,2)+pizda(2,1)
8387         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8388 #ifdef MOMENT
8389         if (swap) then
8390           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8391         else
8392           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8393         endif
8394 #endif
8395         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8396 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8397       endif
8398 C Cartesian derivatives.
8399       if (lprn) then
8400         write (2,*) 'In eello6_graph2'
8401         do iii=1,2
8402           write (2,*) 'iii=',iii
8403           do kkk=1,5
8404             write (2,*) 'kkk=',kkk
8405             do jjj=1,2
8406               write (2,'(3(2f10.5),5x)')
8407      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8408             enddo
8409           enddo
8410         enddo
8411       endif
8412       do iii=1,2
8413         do kkk=1,5
8414           do lll=1,3
8415 #ifdef MOMENT
8416             if (iii.eq.1) then
8417               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8418             else
8419               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8420             endif
8421 #endif
8422             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8423      &        auxvec(1))
8424             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8425             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8426      &        auxvec(1))
8427             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8428             call transpose2(EUg(1,1,k),auxmat(1,1))
8429             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8430      &        pizda(1,1))
8431             vv(1)=pizda(1,1)-pizda(2,2)
8432             vv(2)=pizda(1,2)+pizda(2,1)
8433             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8434 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8435 #ifdef MOMENT
8436             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8437 #else
8438             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8439 #endif
8440             if (swap) then
8441               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8442             else
8443               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8444             endif
8445           enddo
8446         enddo
8447       enddo
8448       return
8449       end
8450 c----------------------------------------------------------------------------
8451       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8452       implicit real*8 (a-h,o-z)
8453       include 'DIMENSIONS'
8454       include 'COMMON.IOUNITS'
8455       include 'COMMON.CHAIN'
8456       include 'COMMON.DERIV'
8457       include 'COMMON.INTERACT'
8458       include 'COMMON.CONTACTS'
8459       include 'COMMON.TORSION'
8460       include 'COMMON.VAR'
8461       include 'COMMON.GEO'
8462       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8463       logical swap
8464 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8465 C                                                                              C
8466 C      Parallel       Antiparallel                                             C
8467 C                                                                              C
8468 C          o             o                                                     C
8469 C         /l\   /   \   /j\                                                    C
8470 C        /   \ /     \ /   \                                                   C
8471 C       /| o |o       o| o |\                                                  C
8472 C       j|/k\|  /      |/k\|l /                                                C
8473 C        /   \ /       /   \ /                                                 C
8474 C       /     o       /     o                                                  C
8475 C       i             i                                                        C
8476 C                                                                              C
8477 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8478 C
8479 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8480 C           energy moment and not to the cluster cumulant.
8481       iti=itortyp(itype(i))
8482       if (j.lt.nres-1) then
8483         itj1=itortyp(itype(j+1))
8484       else
8485         itj1=ntortyp+1
8486       endif
8487       itk=itortyp(itype(k))
8488       itk1=itortyp(itype(k+1))
8489       if (l.lt.nres-1) then
8490         itl1=itortyp(itype(l+1))
8491       else
8492         itl1=ntortyp+1
8493       endif
8494 #ifdef MOMENT
8495       s1=dip(4,jj,i)*dip(4,kk,k)
8496 #endif
8497       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8498       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8499       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8500       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8501       call transpose2(EE(1,1,itk),auxmat(1,1))
8502       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8503       vv(1)=pizda(1,1)+pizda(2,2)
8504       vv(2)=pizda(2,1)-pizda(1,2)
8505       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8506 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8507 cd     & "sum",-(s2+s3+s4)
8508 #ifdef MOMENT
8509       eello6_graph3=-(s1+s2+s3+s4)
8510 #else
8511       eello6_graph3=-(s2+s3+s4)
8512 #endif
8513 c      eello6_graph3=-s4
8514 C Derivatives in gamma(k-1)
8515       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8516       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8517       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8518       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8519 C Derivatives in gamma(l-1)
8520       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8521       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8522       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8523       vv(1)=pizda(1,1)+pizda(2,2)
8524       vv(2)=pizda(2,1)-pizda(1,2)
8525       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8526       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8527 C Cartesian derivatives.
8528       do iii=1,2
8529         do kkk=1,5
8530           do lll=1,3
8531 #ifdef MOMENT
8532             if (iii.eq.1) then
8533               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8534             else
8535               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8536             endif
8537 #endif
8538             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8539      &        auxvec(1))
8540             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8541             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8542      &        auxvec(1))
8543             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8544             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8545      &        pizda(1,1))
8546             vv(1)=pizda(1,1)+pizda(2,2)
8547             vv(2)=pizda(2,1)-pizda(1,2)
8548             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8549 #ifdef MOMENT
8550             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8551 #else
8552             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8553 #endif
8554             if (swap) then
8555               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8556             else
8557               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8558             endif
8559 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8560           enddo
8561         enddo
8562       enddo
8563       return
8564       end
8565 c----------------------------------------------------------------------------
8566       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8567       implicit real*8 (a-h,o-z)
8568       include 'DIMENSIONS'
8569       include 'COMMON.IOUNITS'
8570       include 'COMMON.CHAIN'
8571       include 'COMMON.DERIV'
8572       include 'COMMON.INTERACT'
8573       include 'COMMON.CONTACTS'
8574       include 'COMMON.TORSION'
8575       include 'COMMON.VAR'
8576       include 'COMMON.GEO'
8577       include 'COMMON.FFIELD'
8578       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8579      & auxvec1(2),auxmat1(2,2)
8580       logical swap
8581 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8582 C                                                                              C
8583 C      Parallel       Antiparallel                                             C
8584 C                                                                              C
8585 C          o             o                                                     C
8586 C         /l\   /   \   /j\                                                    C
8587 C        /   \ /     \ /   \                                                   C
8588 C       /| o |o       o| o |\                                                  C
8589 C     \ j|/k\|      \  |/k\|l                                                  C
8590 C      \ /   \       \ /   \                                                   C
8591 C       o     \       o     \                                                  C
8592 C       i             i                                                        C
8593 C                                                                              C
8594 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8595 C
8596 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8597 C           energy moment and not to the cluster cumulant.
8598 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8599       iti=itortyp(itype(i))
8600       itj=itortyp(itype(j))
8601       if (j.lt.nres-1) then
8602         itj1=itortyp(itype(j+1))
8603       else
8604         itj1=ntortyp+1
8605       endif
8606       itk=itortyp(itype(k))
8607       if (k.lt.nres-1) then
8608         itk1=itortyp(itype(k+1))
8609       else
8610         itk1=ntortyp+1
8611       endif
8612       itl=itortyp(itype(l))
8613       if (l.lt.nres-1) then
8614         itl1=itortyp(itype(l+1))
8615       else
8616         itl1=ntortyp+1
8617       endif
8618 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8619 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8620 cd     & ' itl',itl,' itl1',itl1
8621 #ifdef MOMENT
8622       if (imat.eq.1) then
8623         s1=dip(3,jj,i)*dip(3,kk,k)
8624       else
8625         s1=dip(2,jj,j)*dip(2,kk,l)
8626       endif
8627 #endif
8628       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8629       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8630       if (j.eq.l+1) then
8631         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8632         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8633       else
8634         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8635         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8636       endif
8637       call transpose2(EUg(1,1,k),auxmat(1,1))
8638       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8639       vv(1)=pizda(1,1)-pizda(2,2)
8640       vv(2)=pizda(2,1)+pizda(1,2)
8641       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8642 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8643 #ifdef MOMENT
8644       eello6_graph4=-(s1+s2+s3+s4)
8645 #else
8646       eello6_graph4=-(s2+s3+s4)
8647 #endif
8648 C Derivatives in gamma(i-1)
8649       if (i.gt.1) then
8650 #ifdef MOMENT
8651         if (imat.eq.1) then
8652           s1=dipderg(2,jj,i)*dip(3,kk,k)
8653         else
8654           s1=dipderg(4,jj,j)*dip(2,kk,l)
8655         endif
8656 #endif
8657         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8658         if (j.eq.l+1) then
8659           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8660           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8661         else
8662           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8663           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8664         endif
8665         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8666         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8667 cd          write (2,*) 'turn6 derivatives'
8668 #ifdef MOMENT
8669           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8670 #else
8671           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8672 #endif
8673         else
8674 #ifdef MOMENT
8675           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8676 #else
8677           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8678 #endif
8679         endif
8680       endif
8681 C Derivatives in gamma(k-1)
8682 #ifdef MOMENT
8683       if (imat.eq.1) then
8684         s1=dip(3,jj,i)*dipderg(2,kk,k)
8685       else
8686         s1=dip(2,jj,j)*dipderg(4,kk,l)
8687       endif
8688 #endif
8689       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8690       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8691       if (j.eq.l+1) then
8692         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8693         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8694       else
8695         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8696         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8697       endif
8698       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8699       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8700       vv(1)=pizda(1,1)-pizda(2,2)
8701       vv(2)=pizda(2,1)+pizda(1,2)
8702       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8703       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8704 #ifdef MOMENT
8705         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8706 #else
8707         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8708 #endif
8709       else
8710 #ifdef MOMENT
8711         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8712 #else
8713         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8714 #endif
8715       endif
8716 C Derivatives in gamma(j-1) or gamma(l-1)
8717       if (l.eq.j+1 .and. l.gt.1) then
8718         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8719         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8720         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8721         vv(1)=pizda(1,1)-pizda(2,2)
8722         vv(2)=pizda(2,1)+pizda(1,2)
8723         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8724         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8725       else if (j.gt.1) then
8726         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8727         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8728         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8729         vv(1)=pizda(1,1)-pizda(2,2)
8730         vv(2)=pizda(2,1)+pizda(1,2)
8731         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8732         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8733           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8734         else
8735           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8736         endif
8737       endif
8738 C Cartesian derivatives.
8739       do iii=1,2
8740         do kkk=1,5
8741           do lll=1,3
8742 #ifdef MOMENT
8743             if (iii.eq.1) then
8744               if (imat.eq.1) then
8745                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8746               else
8747                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8748               endif
8749             else
8750               if (imat.eq.1) then
8751                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8752               else
8753                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8754               endif
8755             endif
8756 #endif
8757             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8758      &        auxvec(1))
8759             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8760             if (j.eq.l+1) then
8761               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8762      &          b1(1,itj1),auxvec(1))
8763               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8764             else
8765               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8766      &          b1(1,itl1),auxvec(1))
8767               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8768             endif
8769             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8770      &        pizda(1,1))
8771             vv(1)=pizda(1,1)-pizda(2,2)
8772             vv(2)=pizda(2,1)+pizda(1,2)
8773             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8774             if (swap) then
8775               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8776 #ifdef MOMENT
8777                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8778      &             -(s1+s2+s4)
8779 #else
8780                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8781      &             -(s2+s4)
8782 #endif
8783                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8784               else
8785 #ifdef MOMENT
8786                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8787 #else
8788                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8789 #endif
8790                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8791               endif
8792             else
8793 #ifdef MOMENT
8794               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8795 #else
8796               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8797 #endif
8798               if (l.eq.j+1) then
8799                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8800               else
8801                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8802               endif
8803             endif
8804           enddo
8805         enddo
8806       enddo
8807       return
8808       end
8809 c----------------------------------------------------------------------------
8810       double precision function eello_turn6(i,jj,kk)
8811       implicit real*8 (a-h,o-z)
8812       include 'DIMENSIONS'
8813       include 'COMMON.IOUNITS'
8814       include 'COMMON.CHAIN'
8815       include 'COMMON.DERIV'
8816       include 'COMMON.INTERACT'
8817       include 'COMMON.CONTACTS'
8818       include 'COMMON.TORSION'
8819       include 'COMMON.VAR'
8820       include 'COMMON.GEO'
8821       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8822      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8823      &  ggg1(3),ggg2(3)
8824       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8825      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8826 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8827 C           the respective energy moment and not to the cluster cumulant.
8828       s1=0.0d0
8829       s8=0.0d0
8830       s13=0.0d0
8831 c
8832       eello_turn6=0.0d0
8833       j=i+4
8834       k=i+1
8835       l=i+3
8836       iti=itortyp(itype(i))
8837       itk=itortyp(itype(k))
8838       itk1=itortyp(itype(k+1))
8839       itl=itortyp(itype(l))
8840       itj=itortyp(itype(j))
8841 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8842 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8843 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8844 cd        eello6=0.0d0
8845 cd        return
8846 cd      endif
8847 cd      write (iout,*)
8848 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8849 cd     &   ' and',k,l
8850 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8851       do iii=1,2
8852         do kkk=1,5
8853           do lll=1,3
8854             derx_turn(lll,kkk,iii)=0.0d0
8855           enddo
8856         enddo
8857       enddo
8858 cd      eij=1.0d0
8859 cd      ekl=1.0d0
8860 cd      ekont=1.0d0
8861       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8862 cd      eello6_5=0.0d0
8863 cd      write (2,*) 'eello6_5',eello6_5
8864 #ifdef MOMENT
8865       call transpose2(AEA(1,1,1),auxmat(1,1))
8866       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8867       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8868       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8869 #endif
8870       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8871       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8872       s2 = scalar2(b1(1,itk),vtemp1(1))
8873 #ifdef MOMENT
8874       call transpose2(AEA(1,1,2),atemp(1,1))
8875       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8876       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8877       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8878 #endif
8879       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8880       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8881       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8882 #ifdef MOMENT
8883       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8884       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8885       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8886       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8887       ss13 = scalar2(b1(1,itk),vtemp4(1))
8888       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8889 #endif
8890 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8891 c      s1=0.0d0
8892 c      s2=0.0d0
8893 c      s8=0.0d0
8894 c      s12=0.0d0
8895 c      s13=0.0d0
8896       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8897 C Derivatives in gamma(i+2)
8898       s1d =0.0d0
8899       s8d =0.0d0
8900 #ifdef MOMENT
8901       call transpose2(AEA(1,1,1),auxmatd(1,1))
8902       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8903       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8904       call transpose2(AEAderg(1,1,2),atempd(1,1))
8905       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8906       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8907 #endif
8908       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8909       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8910       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
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       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8917 C Derivatives in gamma(i+3)
8918 #ifdef MOMENT
8919       call transpose2(AEA(1,1,1),auxmatd(1,1))
8920       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8921       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8922       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8923 #endif
8924       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8925       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8926       s2d = scalar2(b1(1,itk),vtemp1d(1))
8927 #ifdef MOMENT
8928       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8929       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8930 #endif
8931       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8932 #ifdef MOMENT
8933       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8934       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8935       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8936 #endif
8937 c      s1d=0.0d0
8938 c      s2d=0.0d0
8939 c      s8d=0.0d0
8940 c      s12d=0.0d0
8941 c      s13d=0.0d0
8942 #ifdef MOMENT
8943       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8944      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8945 #else
8946       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8947      &               -0.5d0*ekont*(s2d+s12d)
8948 #endif
8949 C Derivatives in gamma(i+4)
8950       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8951       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8952       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8953 #ifdef MOMENT
8954       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8955       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8956       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8957 #endif
8958 c      s1d=0.0d0
8959 c      s2d=0.0d0
8960 c      s8d=0.0d0
8961 C      s12d=0.0d0
8962 c      s13d=0.0d0
8963 #ifdef MOMENT
8964       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8965 #else
8966       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8967 #endif
8968 C Derivatives in gamma(i+5)
8969 #ifdef MOMENT
8970       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8971       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8972       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8973 #endif
8974       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8975       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8976       s2d = scalar2(b1(1,itk),vtemp1d(1))
8977 #ifdef MOMENT
8978       call transpose2(AEA(1,1,2),atempd(1,1))
8979       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8980       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8981 #endif
8982       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8983       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8984 #ifdef MOMENT
8985       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8986       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8987       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8988 #endif
8989 c      s1d=0.0d0
8990 c      s2d=0.0d0
8991 c      s8d=0.0d0
8992 c      s12d=0.0d0
8993 c      s13d=0.0d0
8994 #ifdef MOMENT
8995       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8996      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8997 #else
8998       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8999      &               -0.5d0*ekont*(s2d+s12d)
9000 #endif
9001 C Cartesian derivatives
9002       do iii=1,2
9003         do kkk=1,5
9004           do lll=1,3
9005 #ifdef MOMENT
9006             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9007             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9008             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9009 #endif
9010             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9011             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9012      &          vtemp1d(1))
9013             s2d = scalar2(b1(1,itk),vtemp1d(1))
9014 #ifdef MOMENT
9015             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9016             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9017             s8d = -(atempd(1,1)+atempd(2,2))*
9018      &           scalar2(cc(1,1,itl),vtemp2(1))
9019 #endif
9020             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9021      &           auxmatd(1,1))
9022             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9023             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9024 c      s1d=0.0d0
9025 c      s2d=0.0d0
9026 c      s8d=0.0d0
9027 c      s12d=0.0d0
9028 c      s13d=0.0d0
9029 #ifdef MOMENT
9030             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9031      &        - 0.5d0*(s1d+s2d)
9032 #else
9033             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9034      &        - 0.5d0*s2d
9035 #endif
9036 #ifdef MOMENT
9037             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9038      &        - 0.5d0*(s8d+s12d)
9039 #else
9040             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9041      &        - 0.5d0*s12d
9042 #endif
9043           enddo
9044         enddo
9045       enddo
9046 #ifdef MOMENT
9047       do kkk=1,5
9048         do lll=1,3
9049           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9050      &      achuj_tempd(1,1))
9051           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9052           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9053           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9054           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9055           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9056      &      vtemp4d(1))
9057           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9058           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9059           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9060         enddo
9061       enddo
9062 #endif
9063 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9064 cd     &  16*eel_turn6_num
9065 cd      goto 1112
9066       if (j.lt.nres-1) then
9067         j1=j+1
9068         j2=j-1
9069       else
9070         j1=j-1
9071         j2=j-2
9072       endif
9073       if (l.lt.nres-1) then
9074         l1=l+1
9075         l2=l-1
9076       else
9077         l1=l-1
9078         l2=l-2
9079       endif
9080       do ll=1,3
9081 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9082 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9083 cgrad        ghalf=0.5d0*ggg1(ll)
9084 cd        ghalf=0.0d0
9085         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9086         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9087         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9088      &    +ekont*derx_turn(ll,2,1)
9089         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9090         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9091      &    +ekont*derx_turn(ll,4,1)
9092         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9093         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9094         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9095 cgrad        ghalf=0.5d0*ggg2(ll)
9096 cd        ghalf=0.0d0
9097         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9098      &    +ekont*derx_turn(ll,2,2)
9099         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9100         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9101      &    +ekont*derx_turn(ll,4,2)
9102         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9103         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9104         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9105       enddo
9106 cd      goto 1112
9107 cgrad      do m=i+1,j-1
9108 cgrad        do ll=1,3
9109 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9110 cgrad        enddo
9111 cgrad      enddo
9112 cgrad      do m=k+1,l-1
9113 cgrad        do ll=1,3
9114 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9115 cgrad        enddo
9116 cgrad      enddo
9117 cgrad1112  continue
9118 cgrad      do m=i+2,j2
9119 cgrad        do ll=1,3
9120 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9121 cgrad        enddo
9122 cgrad      enddo
9123 cgrad      do m=k+2,l2
9124 cgrad        do ll=1,3
9125 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9126 cgrad        enddo
9127 cgrad      enddo
9128 cd      do iii=1,nres-3
9129 cd        write (2,*) iii,g_corr6_loc(iii)
9130 cd      enddo
9131       eello_turn6=ekont*eel_turn6
9132 cd      write (2,*) 'ekont',ekont
9133 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9134       return
9135       end
9136
9137 C-----------------------------------------------------------------------------
9138       double precision function scalar(u,v)
9139 !DIR$ INLINEALWAYS scalar
9140 #ifndef OSF
9141 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9142 #endif
9143       implicit none
9144       double precision u(3),v(3)
9145 cd      double precision sc
9146 cd      integer i
9147 cd      sc=0.0d0
9148 cd      do i=1,3
9149 cd        sc=sc+u(i)*v(i)
9150 cd      enddo
9151 cd      scalar=sc
9152
9153       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9154       return
9155       end
9156 crc-------------------------------------------------
9157       SUBROUTINE MATVEC2(A1,V1,V2)
9158 !DIR$ INLINEALWAYS MATVEC2
9159 #ifndef OSF
9160 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9161 #endif
9162       implicit real*8 (a-h,o-z)
9163       include 'DIMENSIONS'
9164       DIMENSION A1(2,2),V1(2),V2(2)
9165 c      DO 1 I=1,2
9166 c        VI=0.0
9167 c        DO 3 K=1,2
9168 c    3     VI=VI+A1(I,K)*V1(K)
9169 c        Vaux(I)=VI
9170 c    1 CONTINUE
9171
9172       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9173       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9174
9175       v2(1)=vaux1
9176       v2(2)=vaux2
9177       END
9178 C---------------------------------------
9179       SUBROUTINE MATMAT2(A1,A2,A3)
9180 #ifndef OSF
9181 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9182 #endif
9183       implicit real*8 (a-h,o-z)
9184       include 'DIMENSIONS'
9185       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9186 c      DIMENSION AI3(2,2)
9187 c        DO  J=1,2
9188 c          A3IJ=0.0
9189 c          DO K=1,2
9190 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9191 c          enddo
9192 c          A3(I,J)=A3IJ
9193 c       enddo
9194 c      enddo
9195
9196       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9197       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9198       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9199       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9200
9201       A3(1,1)=AI3_11
9202       A3(2,1)=AI3_21
9203       A3(1,2)=AI3_12
9204       A3(2,2)=AI3_22
9205       END
9206
9207 c-------------------------------------------------------------------------
9208       double precision function scalar2(u,v)
9209 !DIR$ INLINEALWAYS scalar2
9210       implicit none
9211       double precision u(2),v(2)
9212       double precision sc
9213       integer i
9214       scalar2=u(1)*v(1)+u(2)*v(2)
9215       return
9216       end
9217
9218 C-----------------------------------------------------------------------------
9219
9220       subroutine transpose2(a,at)
9221 !DIR$ INLINEALWAYS transpose2
9222 #ifndef OSF
9223 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9224 #endif
9225       implicit none
9226       double precision a(2,2),at(2,2)
9227       at(1,1)=a(1,1)
9228       at(1,2)=a(2,1)
9229       at(2,1)=a(1,2)
9230       at(2,2)=a(2,2)
9231       return
9232       end
9233 c--------------------------------------------------------------------------
9234       subroutine transpose(n,a,at)
9235       implicit none
9236       integer n,i,j
9237       double precision a(n,n),at(n,n)
9238       do i=1,n
9239         do j=1,n
9240           at(j,i)=a(i,j)
9241         enddo
9242       enddo
9243       return
9244       end
9245 C---------------------------------------------------------------------------
9246       subroutine prodmat3(a1,a2,kk,transp,prod)
9247 !DIR$ INLINEALWAYS prodmat3
9248 #ifndef OSF
9249 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9250 #endif
9251       implicit none
9252       integer i,j
9253       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9254       logical transp
9255 crc      double precision auxmat(2,2),prod_(2,2)
9256
9257       if (transp) then
9258 crc        call transpose2(kk(1,1),auxmat(1,1))
9259 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9260 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9261
9262            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9263      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9264            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9265      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9266            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9267      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9268            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9269      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9270
9271       else
9272 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9273 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9274
9275            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9276      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9277            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9278      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9279            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9280      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9281            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9282      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9283
9284       endif
9285 c      call transpose2(a2(1,1),a2t(1,1))
9286
9287 crc      print *,transp
9288 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9289 crc      print *,((prod(i,j),i=1,2),j=1,2)
9290
9291       return
9292       end
9293