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         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4980      &   i,theta(i)*rad2deg,phii*rad2deg,
4981      &   phii1*rad2deg,ethetai
4982         etheta=etheta+ethetai
4983         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4984         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4985         gloc(nphi+i-2,icg)=wang*dethetai
4986       enddo
4987       return
4988       end
4989 #endif
4990 #ifdef CRYST_SC
4991 c-----------------------------------------------------------------------------
4992       subroutine esc(escloc)
4993 C Calculate the local energy of a side chain and its derivatives in the
4994 C corresponding virtual-bond valence angles THETA and the spherical angles
4995 C ALPHA and OMEGA.
4996       implicit real*8 (a-h,o-z)
4997       include 'DIMENSIONS'
4998       include 'COMMON.GEO'
4999       include 'COMMON.LOCAL'
5000       include 'COMMON.VAR'
5001       include 'COMMON.INTERACT'
5002       include 'COMMON.DERIV'
5003       include 'COMMON.CHAIN'
5004       include 'COMMON.IOUNITS'
5005       include 'COMMON.NAMES'
5006       include 'COMMON.FFIELD'
5007       include 'COMMON.CONTROL'
5008       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5009      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5010       common /sccalc/ time11,time12,time112,theti,it,nlobit
5011       delta=0.02d0*pi
5012       escloc=0.0D0
5013 c     write (iout,'(a)') 'ESC'
5014       do i=loc_start,loc_end
5015         it=itype(i)
5016         if (it.eq.10) goto 1
5017         nlobit=nlob(it)
5018 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5019 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5020         theti=theta(i+1)-pipol
5021         x(1)=dtan(theti)
5022         x(2)=alph(i)
5023         x(3)=omeg(i)
5024
5025         if (x(2).gt.pi-delta) then
5026           xtemp(1)=x(1)
5027           xtemp(2)=pi-delta
5028           xtemp(3)=x(3)
5029           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5030           xtemp(2)=pi
5031           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5032           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5033      &        escloci,dersc(2))
5034           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5035      &        ddersc0(1),dersc(1))
5036           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5037      &        ddersc0(3),dersc(3))
5038           xtemp(2)=pi-delta
5039           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5040           xtemp(2)=pi
5041           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5042           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5043      &            dersc0(2),esclocbi,dersc02)
5044           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5045      &            dersc12,dersc01)
5046           call splinthet(x(2),0.5d0*delta,ss,ssd)
5047           dersc0(1)=dersc01
5048           dersc0(2)=dersc02
5049           dersc0(3)=0.0d0
5050           do k=1,3
5051             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5052           enddo
5053           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5054 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5055 c    &             esclocbi,ss,ssd
5056           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5057 c         escloci=esclocbi
5058 c         write (iout,*) escloci
5059         else if (x(2).lt.delta) then
5060           xtemp(1)=x(1)
5061           xtemp(2)=delta
5062           xtemp(3)=x(3)
5063           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5064           xtemp(2)=0.0d0
5065           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5066           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5067      &        escloci,dersc(2))
5068           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5069      &        ddersc0(1),dersc(1))
5070           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5071      &        ddersc0(3),dersc(3))
5072           xtemp(2)=delta
5073           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5074           xtemp(2)=0.0d0
5075           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5076           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5077      &            dersc0(2),esclocbi,dersc02)
5078           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5079      &            dersc12,dersc01)
5080           dersc0(1)=dersc01
5081           dersc0(2)=dersc02
5082           dersc0(3)=0.0d0
5083           call splinthet(x(2),0.5d0*delta,ss,ssd)
5084           do k=1,3
5085             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5086           enddo
5087           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5088 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5089 c    &             esclocbi,ss,ssd
5090           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5091 c         write (iout,*) escloci
5092         else
5093           call enesc(x,escloci,dersc,ddummy,.false.)
5094         endif
5095
5096         escloc=escloc+escloci
5097         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5098      &     'escloc',i,escloci
5099 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5100
5101         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5102      &   wscloc*dersc(1)
5103         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5104         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5105     1   continue
5106       enddo
5107       return
5108       end
5109 C---------------------------------------------------------------------------
5110       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5111       implicit real*8 (a-h,o-z)
5112       include 'DIMENSIONS'
5113       include 'COMMON.GEO'
5114       include 'COMMON.LOCAL'
5115       include 'COMMON.IOUNITS'
5116       common /sccalc/ time11,time12,time112,theti,it,nlobit
5117       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5118       double precision contr(maxlob,-1:1)
5119       logical mixed
5120 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5121         escloc_i=0.0D0
5122         do j=1,3
5123           dersc(j)=0.0D0
5124           if (mixed) ddersc(j)=0.0d0
5125         enddo
5126         x3=x(3)
5127
5128 C Because of periodicity of the dependence of the SC energy in omega we have
5129 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5130 C To avoid underflows, first compute & store the exponents.
5131
5132         do iii=-1,1
5133
5134           x(3)=x3+iii*dwapi
5135
5136           do j=1,nlobit
5137             do k=1,3
5138               z(k)=x(k)-censc(k,j,it)
5139             enddo
5140             do k=1,3
5141               Axk=0.0D0
5142               do l=1,3
5143                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5144               enddo
5145               Ax(k,j,iii)=Axk
5146             enddo
5147             expfac=0.0D0
5148             do k=1,3
5149               expfac=expfac+Ax(k,j,iii)*z(k)
5150             enddo
5151             contr(j,iii)=expfac
5152           enddo ! j
5153
5154         enddo ! iii
5155
5156         x(3)=x3
5157 C As in the case of ebend, we want to avoid underflows in exponentiation and
5158 C subsequent NaNs and INFs in energy calculation.
5159 C Find the largest exponent
5160         emin=contr(1,-1)
5161         do iii=-1,1
5162           do j=1,nlobit
5163             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5164           enddo
5165         enddo
5166         emin=0.5D0*emin
5167 cd      print *,'it=',it,' emin=',emin
5168
5169 C Compute the contribution to SC energy and derivatives
5170         do iii=-1,1
5171
5172           do j=1,nlobit
5173 #ifdef OSF
5174             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
5175             if(adexp.ne.adexp) adexp=1.0
5176             expfac=dexp(adexp)
5177 #else
5178             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
5179 #endif
5180 cd          print *,'j=',j,' expfac=',expfac
5181             escloc_i=escloc_i+expfac
5182             do k=1,3
5183               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5184             enddo
5185             if (mixed) then
5186               do k=1,3,2
5187                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5188      &            +gaussc(k,2,j,it))*expfac
5189               enddo
5190             endif
5191           enddo
5192
5193         enddo ! iii
5194
5195         dersc(1)=dersc(1)/cos(theti)**2
5196         ddersc(1)=ddersc(1)/cos(theti)**2
5197         ddersc(3)=ddersc(3)
5198
5199         escloci=-(dlog(escloc_i)-emin)
5200         do j=1,3
5201           dersc(j)=dersc(j)/escloc_i
5202         enddo
5203         if (mixed) then
5204           do j=1,3,2
5205             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5206           enddo
5207         endif
5208       return
5209       end
5210 C------------------------------------------------------------------------------
5211       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5212       implicit real*8 (a-h,o-z)
5213       include 'DIMENSIONS'
5214       include 'COMMON.GEO'
5215       include 'COMMON.LOCAL'
5216       include 'COMMON.IOUNITS'
5217       common /sccalc/ time11,time12,time112,theti,it,nlobit
5218       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5219       double precision contr(maxlob)
5220       logical mixed
5221
5222       escloc_i=0.0D0
5223
5224       do j=1,3
5225         dersc(j)=0.0D0
5226       enddo
5227
5228       do j=1,nlobit
5229         do k=1,2
5230           z(k)=x(k)-censc(k,j,it)
5231         enddo
5232         z(3)=dwapi
5233         do k=1,3
5234           Axk=0.0D0
5235           do l=1,3
5236             Axk=Axk+gaussc(l,k,j,it)*z(l)
5237           enddo
5238           Ax(k,j)=Axk
5239         enddo
5240         expfac=0.0D0
5241         do k=1,3
5242           expfac=expfac+Ax(k,j)*z(k)
5243         enddo
5244         contr(j)=expfac
5245       enddo ! j
5246
5247 C As in the case of ebend, we want to avoid underflows in exponentiation and
5248 C subsequent NaNs and INFs in energy calculation.
5249 C Find the largest exponent
5250       emin=contr(1)
5251       do j=1,nlobit
5252         if (emin.gt.contr(j)) emin=contr(j)
5253       enddo
5254       emin=0.5D0*emin
5255
5256 C Compute the contribution to SC energy and derivatives
5257
5258       dersc12=0.0d0
5259       do j=1,nlobit
5260         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
5261         escloc_i=escloc_i+expfac
5262         do k=1,2
5263           dersc(k)=dersc(k)+Ax(k,j)*expfac
5264         enddo
5265         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5266      &            +gaussc(1,2,j,it))*expfac
5267         dersc(3)=0.0d0
5268       enddo
5269
5270       dersc(1)=dersc(1)/cos(theti)**2
5271       dersc12=dersc12/cos(theti)**2
5272       escloci=-(dlog(escloc_i)-emin)
5273       do j=1,2
5274         dersc(j)=dersc(j)/escloc_i
5275       enddo
5276       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5277       return
5278       end
5279 #else
5280 c----------------------------------------------------------------------------------
5281       subroutine esc(escloc)
5282 C Calculate the local energy of a side chain and its derivatives in the
5283 C corresponding virtual-bond valence angles THETA and the spherical angles
5284 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5285 C added by Urszula Kozlowska. 07/11/2007
5286 C
5287       implicit real*8 (a-h,o-z)
5288       include 'DIMENSIONS'
5289       include 'COMMON.GEO'
5290       include 'COMMON.LOCAL'
5291       include 'COMMON.VAR'
5292       include 'COMMON.SCROT'
5293       include 'COMMON.INTERACT'
5294       include 'COMMON.DERIV'
5295       include 'COMMON.CHAIN'
5296       include 'COMMON.IOUNITS'
5297       include 'COMMON.NAMES'
5298       include 'COMMON.FFIELD'
5299       include 'COMMON.CONTROL'
5300       include 'COMMON.VECTORS'
5301       double precision x_prime(3),y_prime(3),z_prime(3)
5302      &    , sumene,dsc_i,dp2_i,x(65),
5303      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5304      &    de_dxx,de_dyy,de_dzz,de_dt
5305       double precision s1_t,s1_6_t,s2_t,s2_6_t
5306       double precision
5307      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5308      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5309      & dt_dCi(3),dt_dCi1(3)
5310       common /sccalc/ time11,time12,time112,theti,it,nlobit
5311       delta=0.02d0*pi
5312       escloc=0.0D0
5313       do i=loc_start,loc_end
5314         costtab(i+1) =dcos(theta(i+1))
5315         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5316         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5317         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5318         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5319         cosfac=dsqrt(cosfac2)
5320         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5321         sinfac=dsqrt(sinfac2)
5322         it=iabs(itype(i))
5323         if (it.eq.10) goto 1
5324 c
5325 C  Compute the axes of tghe local cartesian coordinates system; store in
5326 c   x_prime, y_prime and z_prime
5327 c
5328         do j=1,3
5329           x_prime(j) = 0.00
5330           y_prime(j) = 0.00
5331           z_prime(j) = 0.00
5332         enddo
5333 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5334 C     &   dc_norm(3,i+nres)
5335         do j = 1,3
5336           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5337           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5338         enddo
5339         do j = 1,3
5340           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5341         enddo
5342 c       write (2,*) "i",i
5343 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5344 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5345 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5346 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5347 c      & " xy",scalar(x_prime(1),y_prime(1)),
5348 c      & " xz",scalar(x_prime(1),z_prime(1)),
5349 c      & " yy",scalar(y_prime(1),y_prime(1)),
5350 c      & " yz",scalar(y_prime(1),z_prime(1)),
5351 c      & " zz",scalar(z_prime(1),z_prime(1))
5352 c
5353 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5354 C to local coordinate system. Store in xx, yy, zz.
5355 c
5356         xx=0.0d0
5357         yy=0.0d0
5358         zz=0.0d0
5359         do j = 1,3
5360           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5361           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5362           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5363         enddo
5364
5365         xxtab(i)=xx
5366         yytab(i)=yy
5367         zztab(i)=zz
5368 C
5369 C Compute the energy of the ith side cbain
5370 C
5371 c        write (2,*) "xx",xx," yy",yy," zz",zz
5372         it=iabs(itype(i))
5373         do j = 1,65
5374           x(j) = sc_parmin(j,it)
5375         enddo
5376 #ifdef CHECK_COORD
5377 Cc diagnostics - remove later
5378         xx1 = dcos(alph(2))
5379         yy1 = dsin(alph(2))*dcos(omeg(2))
5380         zz1 = -dsign(1.0, dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5381         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5382      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5383      &    xx1,yy1,zz1
5384 C,"  --- ", xx_w,yy_w,zz_w
5385 c end diagnostics
5386 #endif
5387         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5388      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5389      &   + x(10)*yy*zz
5390         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5391      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5392      & + x(20)*yy*zz
5393         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5394      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5395      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5396      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5397      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5398      &  +x(40)*xx*yy*zz
5399         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5400      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5401      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5402      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5403      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5404      &  +x(60)*xx*yy*zz
5405         dsc_i   = 0.743d0+x(61)
5406         dp2_i   = 1.9d0+x(62)
5407         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5408      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5409         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5410      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5411         s1=(1+x(63))/(0.1d0 + dscp1)
5412         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5413         s2=(1+x(65))/(0.1d0 + dscp2)
5414         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5415         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5416      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5417 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5418 c     &   sumene4,
5419 c     &   dscp1,dscp2,sumene
5420 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5421         escloc = escloc + sumene
5422 c        write (2,*) "i",i," escloc",sumene,escloc
5423 #ifdef DEBUG
5424 C
5425 C This section to check the numerical derivatives of the energy of ith side
5426 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5427 C #define DEBUG in the code to turn it on.
5428 C
5429         write (2,*) "sumene               =",sumene
5430         aincr=1.0d-7
5431         xxsave=xx
5432         xx=xx+aincr
5433         write (2,*) xx,yy,zz
5434         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5435         de_dxx_num=(sumenep-sumene)/aincr
5436         xx=xxsave
5437         write (2,*) "xx+ sumene from enesc=",sumenep
5438         yysave=yy
5439         yy=yy+aincr
5440         write (2,*) xx,yy,zz
5441         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5442         de_dyy_num=(sumenep-sumene)/aincr
5443         yy=yysave
5444         write (2,*) "yy+ sumene from enesc=",sumenep
5445         zzsave=zz
5446         zz=zz+aincr
5447         write (2,*) xx,yy,zz
5448         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5449         de_dzz_num=(sumenep-sumene)/aincr
5450         zz=zzsave
5451         write (2,*) "zz+ sumene from enesc=",sumenep
5452         costsave=cost2tab(i+1)
5453         sintsave=sint2tab(i+1)
5454         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5455         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5456         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5457         de_dt_num=(sumenep-sumene)/aincr
5458         write (2,*) " t+ sumene from enesc=",sumenep
5459         cost2tab(i+1)=costsave
5460         sint2tab(i+1)=sintsave
5461 C End of diagnostics section.
5462 #endif
5463 C
5464 C Compute the gradient of esc
5465 C
5466         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5467         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5468         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5469         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5470         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5471         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5472         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5473         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5474         pom1=(sumene3*sint2tab(i+1)+sumene1)
5475      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5476         pom2=(sumene4*cost2tab(i+1)+sumene2)
5477      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5478         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5479         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5480      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5481      &  +x(40)*yy*zz
5482         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5483         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5484      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5485      &  +x(60)*yy*zz
5486         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5487      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5488      &        +(pom1+pom2)*pom_dx
5489 #ifdef DEBUG
5490         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5491 #endif
5492 C
5493         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5494         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5495      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5496      &  +x(40)*xx*zz
5497         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5498         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5499      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5500      &  +x(59)*zz**2 +x(60)*xx*zz
5501         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5502      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5503      &        +(pom1-pom2)*pom_dy
5504 #ifdef DEBUG
5505         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5506 #endif
5507 C
5508         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5509      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5510      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5511      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5512      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5513      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5514      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5515      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5516 #ifdef DEBUG
5517         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5518 #endif
5519 C
5520         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5521      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5522      &  +pom1*pom_dt1+pom2*pom_dt2
5523 #ifdef DEBUG
5524         write(2,*), "de_dt = ", de_dt,de_dt_num
5525 #endif
5526 c
5527 C
5528        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5529        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5530        cosfac2xx=cosfac2*xx
5531        sinfac2yy=sinfac2*yy
5532        do k = 1,3
5533          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5534      &      vbld_inv(i+1)
5535          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5536      &      vbld_inv(i)
5537          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5538          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5539 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5540 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5541 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5542 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5543          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5544          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5545          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5546          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5547          dZZ_Ci1(k)=0.0d0
5548          dZZ_Ci(k)=0.0d0
5549          do j=1,3
5550            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5551      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5552            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5553      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5554          enddo
5555
5556          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5557          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5558          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5559 c
5560          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5561          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5562        enddo
5563
5564        do k=1,3
5565          dXX_Ctab(k,i)=dXX_Ci(k)
5566          dXX_C1tab(k,i)=dXX_Ci1(k)
5567          dYY_Ctab(k,i)=dYY_Ci(k)
5568          dYY_C1tab(k,i)=dYY_Ci1(k)
5569          dZZ_Ctab(k,i)=dZZ_Ci(k)
5570          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5571          dXX_XYZtab(k,i)=dXX_XYZ(k)
5572          dYY_XYZtab(k,i)=dYY_XYZ(k)
5573          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5574        enddo
5575
5576        do k = 1,3
5577 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5578 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5579 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5580 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5581 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5582 c     &    dt_dci(k)
5583 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5584 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5585          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5586      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5587          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5588      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5589          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5590      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5591        enddo
5592 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5593 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5594
5595 C to check gradient call subroutine check_grad
5596
5597     1 continue
5598       enddo
5599       return
5600       end
5601 c------------------------------------------------------------------------------
5602       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5603       implicit none
5604       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5605      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5606       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5607      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5608      &   + x(10)*yy*zz
5609       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5610      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5611      & + x(20)*yy*zz
5612       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5613      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5614      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5615      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5616      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5617      &  +x(40)*xx*yy*zz
5618       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5619      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5620      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5621      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5622      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5623      &  +x(60)*xx*yy*zz
5624       dsc_i   = 0.743d0+x(61)
5625       dp2_i   = 1.9d0+x(62)
5626       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5627      &          *(xx*cost2+yy*sint2))
5628       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5629      &          *(xx*cost2-yy*sint2))
5630       s1=(1+x(63))/(0.1d0 + dscp1)
5631       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5632       s2=(1+x(65))/(0.1d0 + dscp2)
5633       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5634       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5635      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5636       enesc=sumene
5637       return
5638       end
5639 #endif
5640 c------------------------------------------------------------------------------
5641       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5642 C
5643 C This procedure calculates two-body contact function g(rij) and its derivative:
5644 C
5645 C           eps0ij                                     !       x < -1
5646 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5647 C            0                                         !       x > 1
5648 C
5649 C where x=(rij-r0ij)/delta
5650 C
5651 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5652 C
5653       implicit none
5654       double precision rij,r0ij,eps0ij,fcont,fprimcont
5655       double precision x,x2,x4,delta
5656 c     delta=0.02D0*r0ij
5657 c      delta=0.2D0*r0ij
5658       x=(rij-r0ij)/delta
5659       if (x.lt.-1.0D0) then
5660         fcont=eps0ij
5661         fprimcont=0.0D0
5662       else if (x.le.1.0D0) then
5663         x2=x*x
5664         x4=x2*x2
5665         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5666         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5667       else
5668         fcont=0.0D0
5669         fprimcont=0.0D0
5670       endif
5671       return
5672       end
5673 c------------------------------------------------------------------------------
5674       subroutine splinthet(theti,delta,ss,ssder)
5675       implicit real*8 (a-h,o-z)
5676       include 'DIMENSIONS'
5677       include 'COMMON.VAR'
5678       include 'COMMON.GEO'
5679       thetup=pi-delta
5680       thetlow=delta
5681       if (theti.gt.pipol) then
5682         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5683       else
5684         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5685         ssder=-ssder
5686       endif
5687       return
5688       end
5689 c------------------------------------------------------------------------------
5690       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5691       implicit none
5692       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5693       double precision ksi,ksi2,ksi3,a1,a2,a3
5694       a1=fprim0*delta/(f1-f0)
5695       a2=3.0d0-2.0d0*a1
5696       a3=a1-2.0d0
5697       ksi=(x-x0)/delta
5698       ksi2=ksi*ksi
5699       ksi3=ksi2*ksi
5700       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5701       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5702       return
5703       end
5704 c------------------------------------------------------------------------------
5705       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5706       implicit none
5707       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5708       double precision ksi,ksi2,ksi3,a1,a2,a3
5709       ksi=(x-x0)/delta
5710       ksi2=ksi*ksi
5711       ksi3=ksi2*ksi
5712       a1=fprim0x*delta
5713       a2=3*(f1x-f0x)-2*fprim0x*delta
5714       a3=fprim0x*delta-2*(f1x-f0x)
5715       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5716       return
5717       end
5718 C-----------------------------------------------------------------------------
5719 #ifdef CRYST_TOR
5720 C-----------------------------------------------------------------------------
5721       subroutine etor(etors,edihcnstr)
5722       implicit real*8 (a-h,o-z)
5723       include 'DIMENSIONS'
5724       include 'COMMON.VAR'
5725       include 'COMMON.GEO'
5726       include 'COMMON.LOCAL'
5727       include 'COMMON.TORSION'
5728       include 'COMMON.INTERACT'
5729       include 'COMMON.DERIV'
5730       include 'COMMON.CHAIN'
5731       include 'COMMON.NAMES'
5732       include 'COMMON.IOUNITS'
5733       include 'COMMON.FFIELD'
5734       include 'COMMON.TORCNSTR'
5735       include 'COMMON.CONTROL'
5736       logical lprn
5737 C Set lprn=.true. for debugging
5738       lprn=.false.
5739 c      lprn=.true.
5740       etors=0.0D0
5741       do i=iphi_start,iphi_end
5742       etors_ii=0.0D0
5743         itori=itortyp(itype(i-2))
5744         itori1=itortyp(itype(i-1))
5745         phii=phi(i)
5746         gloci=0.0D0
5747 C Proline-Proline pair is a special case...
5748         if (itori.eq.3 .and. itori1.eq.3) then
5749           if (phii.gt.-dwapi3) then
5750             cosphi=dcos(3*phii)
5751             fac=1.0D0/(1.0D0-cosphi)
5752             etorsi=v1(1,3,3)*fac
5753             etorsi=etorsi+etorsi
5754             etors=etors+etorsi-v1(1,3,3)
5755             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5756             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5757           endif
5758           do j=1,3
5759             v1ij=v1(j+1,itori,itori1)
5760             v2ij=v2(j+1,itori,itori1)
5761             cosphi=dcos(j*phii)
5762             sinphi=dsin(j*phii)
5763             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5764             if (energy_dec) etors_ii=etors_ii+
5765      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5766             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5767           enddo
5768         else
5769           do j=1,nterm_old
5770             v1ij=v1(j,itori,itori1)
5771             v2ij=v2(j,itori,itori1)
5772             cosphi=dcos(j*phii)
5773             sinphi=dsin(j*phii)
5774             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5775             if (energy_dec) etors_ii=etors_ii+
5776      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5777             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5778           enddo
5779         endif
5780         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5781      &        'etor',i,etors_ii
5782         if (lprn)
5783      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5784      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5785      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5786         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5787         write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5788       enddo
5789 ! 6/20/98 - dihedral angle constraints
5790       edihcnstr=0.0d0
5791       do i=1,ndih_constr
5792         itori=idih_constr(i)
5793         phii=phi(itori)
5794         difi=phii-phi0(i)
5795         if (difi.gt.drange(i)) then
5796           difi=difi-drange(i)
5797           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5798           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5799         else if (difi.lt.-drange(i)) then
5800           difi=difi+drange(i)
5801           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5802           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5803         endif
5804 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5805 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5806       enddo
5807 !      write (iout,*) 'edihcnstr',edihcnstr
5808       return
5809       end
5810 c------------------------------------------------------------------------------
5811       subroutine etor_d(etors_d)
5812       etors_d=0.0d0
5813       return
5814       end
5815 c----------------------------------------------------------------------------
5816 #else
5817       subroutine etor(etors,edihcnstr)
5818       implicit real*8 (a-h,o-z)
5819       include 'DIMENSIONS'
5820       include 'COMMON.VAR'
5821       include 'COMMON.GEO'
5822       include 'COMMON.LOCAL'
5823       include 'COMMON.TORSION'
5824       include 'COMMON.INTERACT'
5825       include 'COMMON.DERIV'
5826       include 'COMMON.CHAIN'
5827       include 'COMMON.NAMES'
5828       include 'COMMON.IOUNITS'
5829       include 'COMMON.FFIELD'
5830       include 'COMMON.TORCNSTR'
5831       include 'COMMON.CONTROL'
5832       logical lprn
5833 C Set lprn=.true. for debugging
5834       lprn=.false.
5835 c     lprn=.true.
5836       etors=0.0D0
5837       do i=iphi_start,iphi_end
5838         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5839      &       .or. itype(i).eq.ntyp1) cycle
5840         etors_ii=0.0D0
5841          if (iabs(itype(i)).eq.20) then
5842          iblock=2
5843          else
5844          iblock=1
5845          endif
5846         itori=itortyp(itype(i-2))
5847         itori1=itortyp(itype(i-1))
5848         phii=phi(i)
5849         gloci=0.0D0
5850 C Regular cosine and sine terms
5851         do j=1,nterm(itori,itori1,iblock)
5852           v1ij=v1(j,itori,itori1,iblock)
5853           v2ij=v2(j,itori,itori1,iblock)
5854           cosphi=dcos(j*phii)
5855           sinphi=dsin(j*phii)
5856           etors=etors+v1ij*cosphi+v2ij*sinphi
5857           if (energy_dec) etors_ii=etors_ii+
5858      &                v1ij*cosphi+v2ij*sinphi
5859           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5860         enddo
5861 C Lorentz terms
5862 C                         v1
5863 C  E = SUM ----------------------------------- - v1
5864 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5865 C
5866         cosphi=dcos(0.5d0*phii)
5867         sinphi=dsin(0.5d0*phii)
5868         do j=1,nlor(itori,itori1,iblock)
5869           vl1ij=vlor1(j,itori,itori1)
5870           vl2ij=vlor2(j,itori,itori1)
5871           vl3ij=vlor3(j,itori,itori1)
5872           pom=vl2ij*cosphi+vl3ij*sinphi
5873           pom1=1.0d0/(pom*pom+1.0d0)
5874           etors=etors+vl1ij*pom1
5875           if (energy_dec) etors_ii=etors_ii+
5876      &                vl1ij*pom1
5877           pom=-pom*pom1*pom1
5878           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5879         enddo
5880 C Subtract the constant term
5881         etors=etors-v0(itori,itori1,iblock)
5882           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5883      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5884         if (lprn)
5885      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5886      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5887      &  (v1(j,itori,itori1,iblock),j=1,6),
5888      &  (v2(j,itori,itori1,iblock),j=1,6)
5889         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5890 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5891       enddo
5892 ! 6/20/98 - dihedral angle constraints
5893       edihcnstr=0.0d0
5894 c      do i=1,ndih_constr
5895       do i=idihconstr_start,idihconstr_end
5896         itori=idih_constr(i)
5897         phii=phi(itori)
5898         difi=pinorm(phii-phi0(i))
5899         if (difi.gt.drange(i)) then
5900           difi=difi-drange(i)
5901           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5902           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5903         else if (difi.lt.-drange(i)) then
5904           difi=difi+drange(i)
5905           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5906           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5907         else
5908           difi=0.0
5909         endif
5910 c        write (iout,*) "gloci", gloc(i-3,icg)
5911 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5912 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5913 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5914       enddo
5915 cd       write (iout,*) 'edihcnstr',edihcnstr
5916       return
5917       end
5918 c----------------------------------------------------------------------------
5919       subroutine etor_d(etors_d)
5920 C 6/23/01 Compute double torsional energy
5921       implicit real*8 (a-h,o-z)
5922       include 'DIMENSIONS'
5923       include 'COMMON.VAR'
5924       include 'COMMON.GEO'
5925       include 'COMMON.LOCAL'
5926       include 'COMMON.TORSION'
5927       include 'COMMON.INTERACT'
5928       include 'COMMON.DERIV'
5929       include 'COMMON.CHAIN'
5930       include 'COMMON.NAMES'
5931       include 'COMMON.IOUNITS'
5932       include 'COMMON.FFIELD'
5933       include 'COMMON.TORCNSTR'
5934       logical lprn
5935 C Set lprn=.true. for debugging
5936       lprn=.false.
5937 c     lprn=.true.
5938       etors_d=0.0D0
5939 c      write(iout,*) "a tu??"
5940       do i=iphid_start,iphid_end
5941         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5942      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5943         itori=itortyp(itype(i-2))
5944         itori1=itortyp(itype(i-1))
5945         itori2=itortyp(itype(i))
5946         phii=phi(i)
5947         phii1=phi(i+1)
5948         gloci1=0.0D0
5949         gloci2=0.0D0
5950         iblock=1
5951         if (iabs(itype(i+1)).eq.20) iblock=2
5952
5953 C Regular cosine and sine terms
5954         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5955           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5956           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5957           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5958           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5959           cosphi1=dcos(j*phii)
5960           sinphi1=dsin(j*phii)
5961           cosphi2=dcos(j*phii1)
5962           sinphi2=dsin(j*phii1)
5963           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5964      &     v2cij*cosphi2+v2sij*sinphi2
5965           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5966           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5967         enddo
5968         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5969           do l=1,k-1
5970             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5971             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5972             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5973             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5974             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5975             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5976             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5977             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5978             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5979      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5980             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5981      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5982             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5983      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5984           enddo
5985         enddo
5986         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5987         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5988       enddo
5989       return
5990       end
5991 #endif
5992 c------------------------------------------------------------------------------
5993       subroutine eback_sc_corr(esccor)
5994 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5995 c        conformational states; temporarily implemented as differences
5996 c        between UNRES torsional potentials (dependent on three types of
5997 c        residues) and the torsional potentials dependent on all 20 types
5998 c        of residues computed from AM1  energy surfaces of terminally-blocked
5999 c        amino-acid residues.
6000       implicit real*8 (a-h,o-z)
6001       include 'DIMENSIONS'
6002       include 'COMMON.VAR'
6003       include 'COMMON.GEO'
6004       include 'COMMON.LOCAL'
6005       include 'COMMON.TORSION'
6006       include 'COMMON.SCCOR'
6007       include 'COMMON.INTERACT'
6008       include 'COMMON.DERIV'
6009       include 'COMMON.CHAIN'
6010       include 'COMMON.NAMES'
6011       include 'COMMON.IOUNITS'
6012       include 'COMMON.FFIELD'
6013       include 'COMMON.CONTROL'
6014       logical lprn
6015 C Set lprn=.true. for debugging
6016       lprn=.false.
6017 c      lprn=.true.
6018 c     write (iout,*) "EBACK_SC_COR",itau_start,itau_end
6019       esccor=0.0D0
6020       do i=itau_start,itau_end
6021         esccor_ii=0.0D0
6022         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6023         isccori=isccortyp(itype(i-2))
6024         isccori1=isccortyp(itype(i-1))
6025         phii=phi(i)
6026 cccc  Added 9 May 2012
6027 cc Tauangle is torsional engle depending on the value of first digit
6028 c(see comment below)
6029 cc Omicron is flat angle depending on the value of first digit
6030 c(see comment below)
6031
6032
6033         do intertyp=1,3 !intertyp
6034 cc Added 09 May 2012 (Adasko)
6035 cc  Intertyp means interaction type of backbone mainchain correlation:
6036 c   1 = SC...Ca...Ca...Ca
6037 c   2 = Ca...Ca...Ca...SC
6038 c   3 = SC...Ca...Ca...SCi
6039         gloci=0.0D0
6040         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6041      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6042      &      (itype(i-1).eq.ntyp1)))
6043      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6044      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6045      &     .or.(itype(i).eq.ntyp1)))
6046      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6047      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6048      &      (itype(i-3).eq.ntyp1)))) cycle
6049         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6050         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6051      & cycle
6052         do j=1,nterm_sccor(isccori,isccori1)
6053           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6054           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6055           cosphi=dcos(j*tauangle(intertyp,i))
6056           sinphi=dsin(j*tauangle(intertyp,i))
6057           esccor=esccor+v1ij*cosphi+v2ij*sinphi
6058           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6059         enddo
6060         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6061 c        write (iout,*) "WTF",intertyp,i,itype(i),v1ij*cosphi+v2ij*sinphi
6062 c     &gloc_sc(intertyp,i-3,icg)
6063         if (lprn)
6064      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6065      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
6066      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
6067      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
6068         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
6069        enddo !intertyp
6070       enddo
6071 c        do i=1,nres
6072 c        write (iout,*) "W@T@F",  gloc_sc(1,i,icg),gloc(i,icg)
6073 c        enddo
6074       return
6075       end
6076 c----------------------------------------------------------------------------
6077       subroutine multibody(ecorr)
6078 C This subroutine calculates multi-body contributions to energy following
6079 C the idea of Skolnick et al. If side chains I and J make a contact and
6080 C at the same time side chains I+1 and J+1 make a contact, an extra
6081 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6082       implicit real*8 (a-h,o-z)
6083       include 'DIMENSIONS'
6084       include 'COMMON.IOUNITS'
6085       include 'COMMON.DERIV'
6086       include 'COMMON.INTERACT'
6087       include 'COMMON.CONTACTS'
6088       double precision gx(3),gx1(3)
6089       logical lprn
6090
6091 C Set lprn=.true. for debugging
6092       lprn=.false.
6093
6094       if (lprn) then
6095         write (iout,'(a)') 'Contact function values:'
6096         do i=nnt,nct-2
6097           write (iout,'(i2,20(1x,i2,f10.5))')
6098      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6099         enddo
6100       endif
6101       ecorr=0.0D0
6102       do i=nnt,nct
6103         do j=1,3
6104           gradcorr(j,i)=0.0D0
6105           gradxorr(j,i)=0.0D0
6106         enddo
6107       enddo
6108       do i=nnt,nct-2
6109
6110         DO ISHIFT = 3,4
6111
6112         i1=i+ishift
6113         num_conti=num_cont(i)
6114         num_conti1=num_cont(i1)
6115         do jj=1,num_conti
6116           j=jcont(jj,i)
6117           do kk=1,num_conti1
6118             j1=jcont(kk,i1)
6119             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6120 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6121 cd   &                   ' ishift=',ishift
6122 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6123 C The system gains extra energy.
6124               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6125             endif   ! j1==j+-ishift
6126           enddo     ! kk
6127         enddo       ! jj
6128
6129         ENDDO ! ISHIFT
6130
6131       enddo         ! i
6132       return
6133       end
6134 c------------------------------------------------------------------------------
6135       double precision function esccorr(i,j,k,l,jj,kk)
6136       implicit real*8 (a-h,o-z)
6137       include 'DIMENSIONS'
6138       include 'COMMON.IOUNITS'
6139       include 'COMMON.DERIV'
6140       include 'COMMON.INTERACT'
6141       include 'COMMON.CONTACTS'
6142       double precision gx(3),gx1(3)
6143       logical lprn
6144       lprn=.false.
6145       eij=facont(jj,i)
6146       ekl=facont(kk,k)
6147 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6148 C Calculate the multi-body contribution to energy.
6149 C Calculate multi-body contributions to the gradient.
6150 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6151 cd   & k,l,(gacont(m,kk,k),m=1,3)
6152       do m=1,3
6153         gx(m) =ekl*gacont(m,jj,i)
6154         gx1(m)=eij*gacont(m,kk,k)
6155         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6156         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6157         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6158         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6159       enddo
6160       do m=i,j-1
6161         do ll=1,3
6162           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6163         enddo
6164       enddo
6165       do m=k,l-1
6166         do ll=1,3
6167           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6168         enddo
6169       enddo
6170       esccorr=-eij*ekl
6171       return
6172       end
6173 c------------------------------------------------------------------------------
6174       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6175 C This subroutine calculates multi-body contributions to hydrogen-bonding
6176       implicit real*8 (a-h,o-z)
6177       include 'DIMENSIONS'
6178       include 'COMMON.IOUNITS'
6179 #ifdef MPI
6180       include "mpif.h"
6181       parameter (max_cont=maxconts)
6182       parameter (max_dim=26)
6183       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6184       double precision zapas(max_dim,maxconts,max_fg_procs),
6185      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6186       common /przechowalnia/ zapas
6187       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6188      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6189 #endif
6190       include 'COMMON.SETUP'
6191       include 'COMMON.FFIELD'
6192       include 'COMMON.DERIV'
6193       include 'COMMON.INTERACT'
6194       include 'COMMON.CONTACTS'
6195       include 'COMMON.CONTROL'
6196       include 'COMMON.LOCAL'
6197       double precision gx(3),gx1(3),time00
6198       logical lprn,ldone
6199
6200 C Set lprn=.true. for debugging
6201       lprn=.false.
6202 #ifdef MPI
6203       n_corr=0
6204       n_corr1=0
6205       if (nfgtasks.le.1) goto 30
6206       if (lprn) then
6207         write (iout,'(a)') 'Contact function values before RECEIVE:'
6208         do i=nnt,nct-2
6209           write (iout,'(2i3,50(1x,i2,f5.2))')
6210      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6211      &    j=1,num_cont_hb(i))
6212         enddo
6213       endif
6214       call flush(iout)
6215       do i=1,ntask_cont_from
6216         ncont_recv(i)=0
6217       enddo
6218       do i=1,ntask_cont_to
6219         ncont_sent(i)=0
6220       enddo
6221 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6222 c     & ntask_cont_to
6223 C Make the list of contacts to send to send to other procesors
6224 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6225 c      call flush(iout)
6226       do i=iturn3_start,iturn3_end
6227 c        write (iout,*) "make contact list turn3",i," num_cont",
6228 c     &    num_cont_hb(i)
6229         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6230       enddo
6231       do i=iturn4_start,iturn4_end
6232 c        write (iout,*) "make contact list turn4",i," num_cont",
6233 c     &   num_cont_hb(i)
6234         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6235       enddo
6236       do ii=1,nat_sent
6237         i=iat_sent(ii)
6238 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6239 c     &    num_cont_hb(i)
6240         do j=1,num_cont_hb(i)
6241         do k=1,4
6242           jjc=jcont_hb(j,i)
6243           iproc=iint_sent_local(k,jjc,ii)
6244 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6245           if (iproc.gt.0) then
6246             ncont_sent(iproc)=ncont_sent(iproc)+1
6247             nn=ncont_sent(iproc)
6248             zapas(1,nn,iproc)=i
6249             zapas(2,nn,iproc)=jjc
6250             zapas(3,nn,iproc)=facont_hb(j,i)
6251             zapas(4,nn,iproc)=ees0p(j,i)
6252             zapas(5,nn,iproc)=ees0m(j,i)
6253             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6254             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6255             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6256             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6257             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6258             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6259             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6260             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6261             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6262             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6263             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6264             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6265             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6266             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6267             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6268             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6269             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6270             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6271             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6272             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6273             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6274           endif
6275         enddo
6276         enddo
6277       enddo
6278       if (lprn) then
6279       write (iout,*)
6280      &  "Numbers of contacts to be sent to other processors",
6281      &  (ncont_sent(i),i=1,ntask_cont_to)
6282       write (iout,*) "Contacts sent"
6283       do ii=1,ntask_cont_to
6284         nn=ncont_sent(ii)
6285         iproc=itask_cont_to(ii)
6286         write (iout,*) nn," contacts to processor",iproc,
6287      &   " of CONT_TO_COMM group"
6288         do i=1,nn
6289           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6290         enddo
6291       enddo
6292       call flush(iout)
6293       endif
6294       CorrelType=477
6295       CorrelID=fg_rank+1
6296       CorrelType1=478
6297       CorrelID1=nfgtasks+fg_rank+1
6298       ireq=0
6299 C Receive the numbers of needed contacts from other processors
6300       do ii=1,ntask_cont_from
6301         iproc=itask_cont_from(ii)
6302         ireq=ireq+1
6303         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6304      &    FG_COMM,req(ireq),IERR)
6305       enddo
6306 c      write (iout,*) "IRECV ended"
6307 c      call flush(iout)
6308 C Send the number of contacts needed by other processors
6309       do ii=1,ntask_cont_to
6310         iproc=itask_cont_to(ii)
6311         ireq=ireq+1
6312         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6313      &    FG_COMM,req(ireq),IERR)
6314       enddo
6315 c      write (iout,*) "ISEND ended"
6316 c      write (iout,*) "number of requests (nn)",ireq
6317       call flush(iout)
6318       if (ireq.gt.0)
6319      &  call MPI_Waitall(ireq,req,status_array,ierr)
6320 c      write (iout,*)
6321 c     &  "Numbers of contacts to be received from other processors",
6322 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6323 c      call flush(iout)
6324 C Receive contacts
6325       ireq=0
6326       do ii=1,ntask_cont_from
6327         iproc=itask_cont_from(ii)
6328         nn=ncont_recv(ii)
6329 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6330 c     &   " of CONT_TO_COMM group"
6331         call flush(iout)
6332         if (nn.gt.0) then
6333           ireq=ireq+1
6334           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6335      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6336 c          write (iout,*) "ireq,req",ireq,req(ireq)
6337         endif
6338       enddo
6339 C Send the contacts to processors that need them
6340       do ii=1,ntask_cont_to
6341         iproc=itask_cont_to(ii)
6342         nn=ncont_sent(ii)
6343 c        write (iout,*) nn," contacts to processor",iproc,
6344 c     &   " of CONT_TO_COMM group"
6345         if (nn.gt.0) then
6346           ireq=ireq+1
6347           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6348      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6349 c          write (iout,*) "ireq,req",ireq,req(ireq)
6350 c          do i=1,nn
6351 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6352 c          enddo
6353         endif
6354       enddo
6355 c      write (iout,*) "number of requests (contacts)",ireq
6356 c      write (iout,*) "req",(req(i),i=1,4)
6357 c      call flush(iout)
6358       if (ireq.gt.0)
6359      & call MPI_Waitall(ireq,req,status_array,ierr)
6360       do iii=1,ntask_cont_from
6361         iproc=itask_cont_from(iii)
6362         nn=ncont_recv(iii)
6363         if (lprn) then
6364         write (iout,*) "Received",nn," contacts from processor",iproc,
6365      &   " of CONT_FROM_COMM group"
6366         call flush(iout)
6367         do i=1,nn
6368           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6369         enddo
6370         call flush(iout)
6371         endif
6372         do i=1,nn
6373           ii=zapas_recv(1,i,iii)
6374 c Flag the received contacts to prevent double-counting
6375           jj=-zapas_recv(2,i,iii)
6376 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6377 c          call flush(iout)
6378           nnn=num_cont_hb(ii)+1
6379           num_cont_hb(ii)=nnn
6380           jcont_hb(nnn,ii)=jj
6381           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6382           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6383           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6384           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6385           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6386           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6387           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6388           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6389           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6390           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6391           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6392           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6393           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6394           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6395           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6396           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6397           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6398           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6399           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6400           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6401           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6402           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6403           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6404           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6405         enddo
6406       enddo
6407       call flush(iout)
6408       if (lprn) then
6409         write (iout,'(a)') 'Contact function values after receive:'
6410         do i=nnt,nct-2
6411           write (iout,'(2i3,50(1x,i3,f5.2))')
6412      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6413      &    j=1,num_cont_hb(i))
6414         enddo
6415         call flush(iout)
6416       endif
6417    30 continue
6418 #endif
6419       if (lprn) then
6420         write (iout,'(a)') 'Contact function values:'
6421         do i=nnt,nct-2
6422           write (iout,'(2i3,50(1x,i3,f5.2))')
6423      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6424      &    j=1,num_cont_hb(i))
6425         enddo
6426       endif
6427       ecorr=0.0D0
6428 C Remove the loop below after debugging !!!
6429       do i=nnt,nct
6430         do j=1,3
6431           gradcorr(j,i)=0.0D0
6432           gradxorr(j,i)=0.0D0
6433         enddo
6434       enddo
6435 C Calculate the local-electrostatic correlation terms
6436       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6437         i1=i+1
6438         num_conti=num_cont_hb(i)
6439         num_conti1=num_cont_hb(i+1)
6440         do jj=1,num_conti
6441           j=jcont_hb(jj,i)
6442           jp=iabs(j)
6443           do kk=1,num_conti1
6444             j1=jcont_hb(kk,i1)
6445             jp1=iabs(j1)
6446 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6447 c     &         ' jj=',jj,' kk=',kk
6448             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6449      &          .or. j.lt.0 .and. j1.gt.0) .and.
6450      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6451 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6452 C The system gains extra energy.
6453               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6454               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6455      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6456               n_corr=n_corr+1
6457             else if (j1.eq.j) then
6458 C Contacts I-J and I-(J+1) occur simultaneously.
6459 C The system loses extra energy.
6460 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6461             endif
6462           enddo ! kk
6463           do kk=1,num_conti
6464             j1=jcont_hb(kk,i)
6465 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6466 c    &         ' jj=',jj,' kk=',kk
6467             if (j1.eq.j+1) then
6468 C Contacts I-J and (I+1)-J occur simultaneously.
6469 C The system loses extra energy.
6470 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6471             endif ! j1==j+1
6472           enddo ! kk
6473         enddo ! jj
6474       enddo ! i
6475       return
6476       end
6477 c------------------------------------------------------------------------------
6478       subroutine add_hb_contact(ii,jj,itask)
6479       implicit real*8 (a-h,o-z)
6480       include "DIMENSIONS"
6481       include "COMMON.IOUNITS"
6482       integer max_cont
6483       integer max_dim
6484       parameter (max_cont=maxconts)
6485       parameter (max_dim=26)
6486       include "COMMON.CONTACTS"
6487       double precision zapas(max_dim,maxconts,max_fg_procs),
6488      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6489       common /przechowalnia/ zapas
6490       integer i,j,ii,jj,iproc,itask(4),nn
6491 c      write (iout,*) "itask",itask
6492       do i=1,2
6493         iproc=itask(i)
6494         if (iproc.gt.0) then
6495           do j=1,num_cont_hb(ii)
6496             jjc=jcont_hb(j,ii)
6497 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6498             if (jjc.eq.jj) then
6499               ncont_sent(iproc)=ncont_sent(iproc)+1
6500               nn=ncont_sent(iproc)
6501               zapas(1,nn,iproc)=ii
6502               zapas(2,nn,iproc)=jjc
6503               zapas(3,nn,iproc)=facont_hb(j,ii)
6504               zapas(4,nn,iproc)=ees0p(j,ii)
6505               zapas(5,nn,iproc)=ees0m(j,ii)
6506               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6507               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6508               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6509               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6510               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6511               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6512               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6513               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6514               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6515               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6516               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6517               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6518               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6519               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6520               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6521               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6522               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6523               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6524               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6525               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6526               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6527               exit
6528             endif
6529           enddo
6530         endif
6531       enddo
6532       return
6533       end
6534 c------------------------------------------------------------------------------
6535       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6536      &  n_corr1)
6537 C This subroutine calculates multi-body contributions to hydrogen-bonding
6538       implicit real*8 (a-h,o-z)
6539       include 'DIMENSIONS'
6540       include 'COMMON.IOUNITS'
6541 #ifdef MPI
6542       include "mpif.h"
6543       parameter (max_cont=maxconts)
6544       parameter (max_dim=70)
6545       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6546       double precision zapas(max_dim,maxconts,max_fg_procs),
6547      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6548       common /przechowalnia/ zapas
6549       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6550      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6551 #endif
6552       include 'COMMON.SETUP'
6553       include 'COMMON.FFIELD'
6554       include 'COMMON.DERIV'
6555       include 'COMMON.LOCAL'
6556       include 'COMMON.INTERACT'
6557       include 'COMMON.CONTACTS'
6558       include 'COMMON.CHAIN'
6559       include 'COMMON.CONTROL'
6560       double precision gx(3),gx1(3)
6561       integer num_cont_hb_old(maxres)
6562       logical lprn,ldone
6563       double precision eello4,eello5,eelo6,eello_turn6
6564       external eello4,eello5,eello6,eello_turn6
6565 C Set lprn=.true. for debugging
6566       lprn=.false.
6567       eturn6=0.0d0
6568 #ifdef MPI
6569       do i=1,nres
6570         num_cont_hb_old(i)=num_cont_hb(i)
6571       enddo
6572       n_corr=0
6573       n_corr1=0
6574       if (nfgtasks.le.1) goto 30
6575       if (lprn) then
6576         write (iout,'(a)') 'Contact function values before RECEIVE:'
6577         do i=nnt,nct-2
6578           write (iout,'(2i3,50(1x,i2,f5.2))')
6579      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6580      &    j=1,num_cont_hb(i))
6581         enddo
6582       endif
6583       call flush(iout)
6584       do i=1,ntask_cont_from
6585         ncont_recv(i)=0
6586       enddo
6587       do i=1,ntask_cont_to
6588         ncont_sent(i)=0
6589       enddo
6590 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6591 c     & ntask_cont_to
6592 C Make the list of contacts to send to send to other procesors
6593       do i=iturn3_start,iturn3_end
6594 c        write (iout,*) "make contact list turn3",i," num_cont",
6595 c     &    num_cont_hb(i)
6596         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6597       enddo
6598       do i=iturn4_start,iturn4_end
6599 c        write (iout,*) "make contact list turn4",i," num_cont",
6600 c     &   num_cont_hb(i)
6601         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6602       enddo
6603       do ii=1,nat_sent
6604         i=iat_sent(ii)
6605 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6606 c     &    num_cont_hb(i)
6607         do j=1,num_cont_hb(i)
6608         do k=1,4
6609           jjc=jcont_hb(j,i)
6610           iproc=iint_sent_local(k,jjc,ii)
6611 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6612           if (iproc.ne.0) then
6613             ncont_sent(iproc)=ncont_sent(iproc)+1
6614             nn=ncont_sent(iproc)
6615             zapas(1,nn,iproc)=i
6616             zapas(2,nn,iproc)=jjc
6617             zapas(3,nn,iproc)=d_cont(j,i)
6618             ind=3
6619             do kk=1,3
6620               ind=ind+1
6621               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6622             enddo
6623             do kk=1,2
6624               do ll=1,2
6625                 ind=ind+1
6626                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6627               enddo
6628             enddo
6629             do jj=1,5
6630               do kk=1,3
6631                 do ll=1,2
6632                   do mm=1,2
6633                     ind=ind+1
6634                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6635                   enddo
6636                 enddo
6637               enddo
6638             enddo
6639           endif
6640         enddo
6641         enddo
6642       enddo
6643       if (lprn) then
6644       write (iout,*)
6645      &  "Numbers of contacts to be sent to other processors",
6646      &  (ncont_sent(i),i=1,ntask_cont_to)
6647       write (iout,*) "Contacts sent"
6648       do ii=1,ntask_cont_to
6649         nn=ncont_sent(ii)
6650         iproc=itask_cont_to(ii)
6651         write (iout,*) nn," contacts to processor",iproc,
6652      &   " of CONT_TO_COMM group"
6653         do i=1,nn
6654           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6655         enddo
6656       enddo
6657       call flush(iout)
6658       endif
6659       CorrelType=477
6660       CorrelID=fg_rank+1
6661       CorrelType1=478
6662       CorrelID1=nfgtasks+fg_rank+1
6663       ireq=0
6664 C Receive the numbers of needed contacts from other processors
6665       do ii=1,ntask_cont_from
6666         iproc=itask_cont_from(ii)
6667         ireq=ireq+1
6668         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6669      &    FG_COMM,req(ireq),IERR)
6670       enddo
6671 c      write (iout,*) "IRECV ended"
6672 c      call flush(iout)
6673 C Send the number of contacts needed by other processors
6674       do ii=1,ntask_cont_to
6675         iproc=itask_cont_to(ii)
6676         ireq=ireq+1
6677         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6678      &    FG_COMM,req(ireq),IERR)
6679       enddo
6680 c      write (iout,*) "ISEND ended"
6681 c      write (iout,*) "number of requests (nn)",ireq
6682       call flush(iout)
6683       if (ireq.gt.0)
6684      &  call MPI_Waitall(ireq,req,status_array,ierr)
6685 c      write (iout,*)
6686 c     &  "Numbers of contacts to be received from other processors",
6687 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6688 c      call flush(iout)
6689 C Receive contacts
6690       ireq=0
6691       do ii=1,ntask_cont_from
6692         iproc=itask_cont_from(ii)
6693         nn=ncont_recv(ii)
6694 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6695 c     &   " of CONT_TO_COMM group"
6696         call flush(iout)
6697         if (nn.gt.0) then
6698           ireq=ireq+1
6699           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6700      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6701 c          write (iout,*) "ireq,req",ireq,req(ireq)
6702         endif
6703       enddo
6704 C Send the contacts to processors that need them
6705       do ii=1,ntask_cont_to
6706         iproc=itask_cont_to(ii)
6707         nn=ncont_sent(ii)
6708 c        write (iout,*) nn," contacts to processor",iproc,
6709 c     &   " of CONT_TO_COMM group"
6710         if (nn.gt.0) then
6711           ireq=ireq+1
6712           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6713      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6714 c          write (iout,*) "ireq,req",ireq,req(ireq)
6715 c          do i=1,nn
6716 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6717 c          enddo
6718         endif
6719       enddo
6720 c      write (iout,*) "number of requests (contacts)",ireq
6721 c      write (iout,*) "req",(req(i),i=1,4)
6722 c      call flush(iout)
6723       if (ireq.gt.0)
6724      & call MPI_Waitall(ireq,req,status_array,ierr)
6725       do iii=1,ntask_cont_from
6726         iproc=itask_cont_from(iii)
6727         nn=ncont_recv(iii)
6728         if (lprn) then
6729         write (iout,*) "Received",nn," contacts from processor",iproc,
6730      &   " of CONT_FROM_COMM group"
6731         call flush(iout)
6732         do i=1,nn
6733           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6734         enddo
6735         call flush(iout)
6736         endif
6737         do i=1,nn
6738           ii=zapas_recv(1,i,iii)
6739 c Flag the received contacts to prevent double-counting
6740           jj=-zapas_recv(2,i,iii)
6741 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6742 c          call flush(iout)
6743           nnn=num_cont_hb(ii)+1
6744           num_cont_hb(ii)=nnn
6745           jcont_hb(nnn,ii)=jj
6746           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6747           ind=3
6748           do kk=1,3
6749             ind=ind+1
6750             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6751           enddo
6752           do kk=1,2
6753             do ll=1,2
6754               ind=ind+1
6755               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6756             enddo
6757           enddo
6758           do jj=1,5
6759             do kk=1,3
6760               do ll=1,2
6761                 do mm=1,2
6762                   ind=ind+1
6763                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6764                 enddo
6765               enddo
6766             enddo
6767           enddo
6768         enddo
6769       enddo
6770       call flush(iout)
6771       if (lprn) then
6772         write (iout,'(a)') 'Contact function values after receive:'
6773         do i=nnt,nct-2
6774           write (iout,'(2i3,50(1x,i3,5f6.3))')
6775      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6776      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6777         enddo
6778         call flush(iout)
6779       endif
6780    30 continue
6781 #endif
6782       if (lprn) then
6783         write (iout,'(a)') 'Contact function values:'
6784         do i=nnt,nct-2
6785           write (iout,'(2i3,50(1x,i2,5f6.3))')
6786      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6787      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6788         enddo
6789       endif
6790       ecorr=0.0D0
6791       ecorr5=0.0d0
6792       ecorr6=0.0d0
6793 C Remove the loop below after debugging !!!
6794       do i=nnt,nct
6795         do j=1,3
6796           gradcorr(j,i)=0.0D0
6797           gradxorr(j,i)=0.0D0
6798         enddo
6799       enddo
6800 C Calculate the dipole-dipole interaction energies
6801       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6802       do i=iatel_s,iatel_e+1
6803         num_conti=num_cont_hb(i)
6804         do jj=1,num_conti
6805           j=jcont_hb(jj,i)
6806 #ifdef MOMENT
6807           call dipole(i,j,jj)
6808 #endif
6809         enddo
6810       enddo
6811       endif
6812 C Calculate the local-electrostatic correlation terms
6813 c                write (iout,*) "gradcorr5 in eello5 before loop"
6814 c                do iii=1,nres
6815 c                  write (iout,'(i5,3f10.5)')
6816 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6817 c                enddo
6818       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6819 c        write (iout,*) "corr loop i",i
6820         i1=i+1
6821         num_conti=num_cont_hb(i)
6822         num_conti1=num_cont_hb(i+1)
6823         do jj=1,num_conti
6824           j=jcont_hb(jj,i)
6825           jp=iabs(j)
6826           do kk=1,num_conti1
6827             j1=jcont_hb(kk,i1)
6828             jp1=iabs(j1)
6829 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6830 c     &         ' jj=',jj,' kk=',kk
6831 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6832             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6833      &          .or. j.lt.0 .and. j1.gt.0) .and.
6834      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6835 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6836 C The system gains extra energy.
6837               n_corr=n_corr+1
6838               sqd1=dsqrt(d_cont(jj,i))
6839               sqd2=dsqrt(d_cont(kk,i1))
6840               sred_geom = sqd1*sqd2
6841               IF (sred_geom.lt.cutoff_corr) THEN
6842                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6843      &            ekont,fprimcont)
6844 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6845 cd     &         ' jj=',jj,' kk=',kk
6846                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6847                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6848                 do l=1,3
6849                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6850                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6851                 enddo
6852                 n_corr1=n_corr1+1
6853 cd               write (iout,*) 'sred_geom=',sred_geom,
6854 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6855 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6856 cd               write (iout,*) "g_contij",g_contij
6857 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6858 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6859                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6860                 if (wcorr4.gt.0.0d0)
6861      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6862                   if (energy_dec.and.wcorr4.gt.0.0d0)
6863      1                 write (iout,'(a6,4i5,0pf7.3)')
6864      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6865 c                write (iout,*) "gradcorr5 before eello5"
6866 c                do iii=1,nres
6867 c                  write (iout,'(i5,3f10.5)')
6868 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6869 c                enddo
6870                 if (wcorr5.gt.0.0d0)
6871      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6872 c                write (iout,*) "gradcorr5 after eello5"
6873 c                do iii=1,nres
6874 c                  write (iout,'(i5,3f10.5)')
6875 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6876 c                enddo
6877                   if (energy_dec.and.wcorr5.gt.0.0d0)
6878      1                 write (iout,'(a6,4i5,0pf7.3)')
6879      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6880 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6881 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6882                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6883      &               .or. wturn6.eq.0.0d0))then
6884 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6885                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6886                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6887      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6888 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6889 cd     &            'ecorr6=',ecorr6
6890 cd                write (iout,'(4e15.5)') sred_geom,
6891 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6892 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6893 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6894                 else if (wturn6.gt.0.0d0
6895      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6896 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6897                   eturn6=eturn6+eello_turn6(i,jj,kk)
6898                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6899      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6900 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6901                 endif
6902               ENDIF
6903 1111          continue
6904             endif
6905           enddo ! kk
6906         enddo ! jj
6907       enddo ! i
6908       do i=1,nres
6909         num_cont_hb(i)=num_cont_hb_old(i)
6910       enddo
6911 c                write (iout,*) "gradcorr5 in eello5"
6912 c                do iii=1,nres
6913 c                  write (iout,'(i5,3f10.5)')
6914 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6915 c                enddo
6916       return
6917       end
6918 c------------------------------------------------------------------------------
6919       subroutine add_hb_contact_eello(ii,jj,itask)
6920       implicit real*8 (a-h,o-z)
6921       include "DIMENSIONS"
6922       include "COMMON.IOUNITS"
6923       integer max_cont
6924       integer max_dim
6925       parameter (max_cont=maxconts)
6926       parameter (max_dim=70)
6927       include "COMMON.CONTACTS"
6928       double precision zapas(max_dim,maxconts,max_fg_procs),
6929      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6930       common /przechowalnia/ zapas
6931       integer i,j,ii,jj,iproc,itask(4),nn
6932 c      write (iout,*) "itask",itask
6933       do i=1,2
6934         iproc=itask(i)
6935         if (iproc.gt.0) then
6936           do j=1,num_cont_hb(ii)
6937             jjc=jcont_hb(j,ii)
6938 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6939             if (jjc.eq.jj) then
6940               ncont_sent(iproc)=ncont_sent(iproc)+1
6941               nn=ncont_sent(iproc)
6942               zapas(1,nn,iproc)=ii
6943               zapas(2,nn,iproc)=jjc
6944               zapas(3,nn,iproc)=d_cont(j,ii)
6945               ind=3
6946               do kk=1,3
6947                 ind=ind+1
6948                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6949               enddo
6950               do kk=1,2
6951                 do ll=1,2
6952                   ind=ind+1
6953                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6954                 enddo
6955               enddo
6956               do jj=1,5
6957                 do kk=1,3
6958                   do ll=1,2
6959                     do mm=1,2
6960                       ind=ind+1
6961                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6962                     enddo
6963                   enddo
6964                 enddo
6965               enddo
6966               exit
6967             endif
6968           enddo
6969         endif
6970       enddo
6971       return
6972       end
6973 c------------------------------------------------------------------------------
6974       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6975       implicit real*8 (a-h,o-z)
6976       include 'DIMENSIONS'
6977       include 'COMMON.IOUNITS'
6978       include 'COMMON.DERIV'
6979       include 'COMMON.INTERACT'
6980       include 'COMMON.CONTACTS'
6981       double precision gx(3),gx1(3)
6982       logical lprn
6983       lprn=.false.
6984       eij=facont_hb(jj,i)
6985       ekl=facont_hb(kk,k)
6986       ees0pij=ees0p(jj,i)
6987       ees0pkl=ees0p(kk,k)
6988       ees0mij=ees0m(jj,i)
6989       ees0mkl=ees0m(kk,k)
6990       ekont=eij*ekl
6991       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6992 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6993 C Following 4 lines for diagnostics.
6994 cd    ees0pkl=0.0D0
6995 cd    ees0pij=1.0D0
6996 cd    ees0mkl=0.0D0
6997 cd    ees0mij=1.0D0
6998 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6999 c     & 'Contacts ',i,j,
7000 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
7001 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
7002 c     & 'gradcorr_long'
7003 C Calculate the multi-body contribution to energy.
7004 c      ecorr=ecorr+ekont*ees
7005 C Calculate multi-body contributions to the gradient.
7006       coeffpees0pij=coeffp*ees0pij
7007       coeffmees0mij=coeffm*ees0mij
7008       coeffpees0pkl=coeffp*ees0pkl
7009       coeffmees0mkl=coeffm*ees0mkl
7010       do ll=1,3
7011 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
7012         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
7013      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
7014      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
7015         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
7016      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
7017      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
7018 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
7019         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
7020      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
7021      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
7022         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
7023      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
7024      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
7025         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
7026      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
7027      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
7028         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
7029         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
7030         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
7031      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
7032      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
7033         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
7034         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
7035 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
7036       enddo
7037 c      write (iout,*)
7038 cgrad      do m=i+1,j-1
7039 cgrad        do ll=1,3
7040 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7041 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
7042 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
7043 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
7044 cgrad        enddo
7045 cgrad      enddo
7046 cgrad      do m=k+1,l-1
7047 cgrad        do ll=1,3
7048 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
7049 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
7050 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
7051 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
7052 cgrad        enddo
7053 cgrad      enddo
7054 c      write (iout,*) "ehbcorr",ekont*ees
7055       ehbcorr=ekont*ees
7056       return
7057       end
7058 #ifdef MOMENT
7059 C---------------------------------------------------------------------------
7060       subroutine dipole(i,j,jj)
7061       implicit real*8 (a-h,o-z)
7062       include 'DIMENSIONS'
7063       include 'COMMON.IOUNITS'
7064       include 'COMMON.CHAIN'
7065       include 'COMMON.FFIELD'
7066       include 'COMMON.DERIV'
7067       include 'COMMON.INTERACT'
7068       include 'COMMON.CONTACTS'
7069       include 'COMMON.TORSION'
7070       include 'COMMON.VAR'
7071       include 'COMMON.GEO'
7072       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
7073      &  auxmat(2,2)
7074       iti1 = itortyp(itype(i+1))
7075       if (j.lt.nres-1) then
7076         itj1 = itortyp(itype(j+1))
7077       else
7078         itj1=ntortyp+1
7079       endif
7080       do iii=1,2
7081         dipi(iii,1)=Ub2(iii,i)
7082         dipderi(iii)=Ub2der(iii,i)
7083         dipi(iii,2)=b1(iii,iti1)
7084         dipj(iii,1)=Ub2(iii,j)
7085         dipderj(iii)=Ub2der(iii,j)
7086         dipj(iii,2)=b1(iii,itj1)
7087       enddo
7088       kkk=0
7089       do iii=1,2
7090         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7091         do jjj=1,2
7092           kkk=kkk+1
7093           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7094         enddo
7095       enddo
7096       do kkk=1,5
7097         do lll=1,3
7098           mmm=0
7099           do iii=1,2
7100             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7101      &        auxvec(1))
7102             do jjj=1,2
7103               mmm=mmm+1
7104               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7105             enddo
7106           enddo
7107         enddo
7108       enddo
7109       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7110       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7111       do iii=1,2
7112         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7113       enddo
7114       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7115       do iii=1,2
7116         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7117       enddo
7118       return
7119       end
7120 #endif
7121 C---------------------------------------------------------------------------
7122       subroutine calc_eello(i,j,k,l,jj,kk)
7123 C
7124 C This subroutine computes matrices and vectors needed to calculate
7125 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7126 C
7127       implicit real*8 (a-h,o-z)
7128       include 'DIMENSIONS'
7129       include 'COMMON.IOUNITS'
7130       include 'COMMON.CHAIN'
7131       include 'COMMON.DERIV'
7132       include 'COMMON.INTERACT'
7133       include 'COMMON.CONTACTS'
7134       include 'COMMON.TORSION'
7135       include 'COMMON.VAR'
7136       include 'COMMON.GEO'
7137       include 'COMMON.FFIELD'
7138       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7139      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7140       logical lprn
7141       common /kutas/ lprn
7142 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7143 cd     & ' jj=',jj,' kk=',kk
7144 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7145 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7146 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7147       do iii=1,2
7148         do jjj=1,2
7149           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7150           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7151         enddo
7152       enddo
7153       call transpose2(aa1(1,1),aa1t(1,1))
7154       call transpose2(aa2(1,1),aa2t(1,1))
7155       do kkk=1,5
7156         do lll=1,3
7157           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7158      &      aa1tder(1,1,lll,kkk))
7159           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7160      &      aa2tder(1,1,lll,kkk))
7161         enddo
7162       enddo
7163       if (l.eq.j+1) then
7164 C parallel orientation of the two CA-CA-CA frames.
7165         if (i.gt.1) then
7166           iti=itortyp(itype(i))
7167         else
7168           iti=ntortyp+1
7169         endif
7170         itk1=itortyp(itype(k+1))
7171         itj=itortyp(itype(j))
7172         if (l.lt.nres-1) then
7173           itl1=itortyp(itype(l+1))
7174         else
7175           itl1=ntortyp+1
7176         endif
7177 C A1 kernel(j+1) A2T
7178 cd        do iii=1,2
7179 cd          write (iout,'(3f10.5,5x,3f10.5)')
7180 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7181 cd        enddo
7182         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7183      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7184      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7185 C Following matrices are needed only for 6-th order cumulants
7186         IF (wcorr6.gt.0.0d0) THEN
7187         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7188      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7189      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7190         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7191      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7192      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7193      &   ADtEAderx(1,1,1,1,1,1))
7194         lprn=.false.
7195         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7196      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7197      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7198      &   ADtEA1derx(1,1,1,1,1,1))
7199         ENDIF
7200 C End 6-th order cumulants
7201 cd        lprn=.false.
7202 cd        if (lprn) then
7203 cd        write (2,*) 'In calc_eello6'
7204 cd        do iii=1,2
7205 cd          write (2,*) 'iii=',iii
7206 cd          do kkk=1,5
7207 cd            write (2,*) 'kkk=',kkk
7208 cd            do jjj=1,2
7209 cd              write (2,'(3(2f10.5),5x)')
7210 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7211 cd            enddo
7212 cd          enddo
7213 cd        enddo
7214 cd        endif
7215         call transpose2(EUgder(1,1,k),auxmat(1,1))
7216         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7217         call transpose2(EUg(1,1,k),auxmat(1,1))
7218         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7219         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7220         do iii=1,2
7221           do kkk=1,5
7222             do lll=1,3
7223               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7224      &          EAEAderx(1,1,lll,kkk,iii,1))
7225             enddo
7226           enddo
7227         enddo
7228 C A1T kernel(i+1) A2
7229         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7230      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7231      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7232 C Following matrices are needed only for 6-th order cumulants
7233         IF (wcorr6.gt.0.0d0) THEN
7234         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7235      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7236      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7237         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7238      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7239      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7240      &   ADtEAderx(1,1,1,1,1,2))
7241         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7242      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7243      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7244      &   ADtEA1derx(1,1,1,1,1,2))
7245         ENDIF
7246 C End 6-th order cumulants
7247         call transpose2(EUgder(1,1,l),auxmat(1,1))
7248         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7249         call transpose2(EUg(1,1,l),auxmat(1,1))
7250         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7251         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7252         do iii=1,2
7253           do kkk=1,5
7254             do lll=1,3
7255               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7256      &          EAEAderx(1,1,lll,kkk,iii,2))
7257             enddo
7258           enddo
7259         enddo
7260 C AEAb1 and AEAb2
7261 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7262 C They are needed only when the fifth- or the sixth-order cumulants are
7263 C indluded.
7264         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7265         call transpose2(AEA(1,1,1),auxmat(1,1))
7266         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7267         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7268         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7269         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7270         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7271         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7272         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7273         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7274         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7275         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7276         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7277         call transpose2(AEA(1,1,2),auxmat(1,1))
7278         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7279         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7280         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7281         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7282         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7283         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7284         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7285         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7286         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7287         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7288         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7289 C Calculate the Cartesian derivatives of the vectors.
7290         do iii=1,2
7291           do kkk=1,5
7292             do lll=1,3
7293               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7294               call matvec2(auxmat(1,1),b1(1,iti),
7295      &          AEAb1derx(1,lll,kkk,iii,1,1))
7296               call matvec2(auxmat(1,1),Ub2(1,i),
7297      &          AEAb2derx(1,lll,kkk,iii,1,1))
7298               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7299      &          AEAb1derx(1,lll,kkk,iii,2,1))
7300               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7301      &          AEAb2derx(1,lll,kkk,iii,2,1))
7302               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7303               call matvec2(auxmat(1,1),b1(1,itj),
7304      &          AEAb1derx(1,lll,kkk,iii,1,2))
7305               call matvec2(auxmat(1,1),Ub2(1,j),
7306      &          AEAb2derx(1,lll,kkk,iii,1,2))
7307               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7308      &          AEAb1derx(1,lll,kkk,iii,2,2))
7309               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7310      &          AEAb2derx(1,lll,kkk,iii,2,2))
7311             enddo
7312           enddo
7313         enddo
7314         ENDIF
7315 C End vectors
7316       else
7317 C Antiparallel orientation of the two CA-CA-CA frames.
7318         if (i.gt.1) then
7319           iti=itortyp(itype(i))
7320         else
7321           iti=ntortyp+1
7322         endif
7323         itk1=itortyp(itype(k+1))
7324         itl=itortyp(itype(l))
7325         itj=itortyp(itype(j))
7326         if (j.lt.nres-1) then
7327           itj1=itortyp(itype(j+1))
7328         else
7329           itj1=ntortyp+1
7330         endif
7331 C A2 kernel(j-1)T A1T
7332         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7333      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7334      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7335 C Following matrices are needed only for 6-th order cumulants
7336         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7337      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7338         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7339      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7340      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7341         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7342      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7343      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7344      &   ADtEAderx(1,1,1,1,1,1))
7345         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7346      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7347      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7348      &   ADtEA1derx(1,1,1,1,1,1))
7349         ENDIF
7350 C End 6-th order cumulants
7351         call transpose2(EUgder(1,1,k),auxmat(1,1))
7352         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7353         call transpose2(EUg(1,1,k),auxmat(1,1))
7354         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7355         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7356         do iii=1,2
7357           do kkk=1,5
7358             do lll=1,3
7359               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7360      &          EAEAderx(1,1,lll,kkk,iii,1))
7361             enddo
7362           enddo
7363         enddo
7364 C A2T kernel(i+1)T A1
7365         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7366      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7367      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7368 C Following matrices are needed only for 6-th order cumulants
7369         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7370      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7371         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7372      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7373      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7374         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7375      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7376      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7377      &   ADtEAderx(1,1,1,1,1,2))
7378         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7379      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7380      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7381      &   ADtEA1derx(1,1,1,1,1,2))
7382         ENDIF
7383 C End 6-th order cumulants
7384         call transpose2(EUgder(1,1,j),auxmat(1,1))
7385         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7386         call transpose2(EUg(1,1,j),auxmat(1,1))
7387         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7388         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7389         do iii=1,2
7390           do kkk=1,5
7391             do lll=1,3
7392               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7393      &          EAEAderx(1,1,lll,kkk,iii,2))
7394             enddo
7395           enddo
7396         enddo
7397 C AEAb1 and AEAb2
7398 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7399 C They are needed only when the fifth- or the sixth-order cumulants are
7400 C indluded.
7401         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7402      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7403         call transpose2(AEA(1,1,1),auxmat(1,1))
7404         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7405         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7406         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7407         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7408         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7409         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7410         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7411         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7412         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7413         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7414         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7415         call transpose2(AEA(1,1,2),auxmat(1,1))
7416         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7417         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7418         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7419         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7420         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7421         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7422         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7423         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7424         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7425         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7426         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7427 C Calculate the Cartesian derivatives of the vectors.
7428         do iii=1,2
7429           do kkk=1,5
7430             do lll=1,3
7431               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7432               call matvec2(auxmat(1,1),b1(1,iti),
7433      &          AEAb1derx(1,lll,kkk,iii,1,1))
7434               call matvec2(auxmat(1,1),Ub2(1,i),
7435      &          AEAb2derx(1,lll,kkk,iii,1,1))
7436               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7437      &          AEAb1derx(1,lll,kkk,iii,2,1))
7438               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7439      &          AEAb2derx(1,lll,kkk,iii,2,1))
7440               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7441               call matvec2(auxmat(1,1),b1(1,itl),
7442      &          AEAb1derx(1,lll,kkk,iii,1,2))
7443               call matvec2(auxmat(1,1),Ub2(1,l),
7444      &          AEAb2derx(1,lll,kkk,iii,1,2))
7445               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7446      &          AEAb1derx(1,lll,kkk,iii,2,2))
7447               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7448      &          AEAb2derx(1,lll,kkk,iii,2,2))
7449             enddo
7450           enddo
7451         enddo
7452         ENDIF
7453 C End vectors
7454       endif
7455       return
7456       end
7457 C---------------------------------------------------------------------------
7458       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7459      &  KK,KKderg,AKA,AKAderg,AKAderx)
7460       implicit none
7461       integer nderg
7462       logical transp
7463       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7464      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7465      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7466       integer iii,kkk,lll
7467       integer jjj,mmm
7468       logical lprn
7469       common /kutas/ lprn
7470       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7471       do iii=1,nderg
7472         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7473      &    AKAderg(1,1,iii))
7474       enddo
7475 cd      if (lprn) write (2,*) 'In kernel'
7476       do kkk=1,5
7477 cd        if (lprn) write (2,*) 'kkk=',kkk
7478         do lll=1,3
7479           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7480      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7481 cd          if (lprn) then
7482 cd            write (2,*) 'lll=',lll
7483 cd            write (2,*) 'iii=1'
7484 cd            do jjj=1,2
7485 cd              write (2,'(3(2f10.5),5x)')
7486 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7487 cd            enddo
7488 cd          endif
7489           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7490      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7491 cd          if (lprn) then
7492 cd            write (2,*) 'lll=',lll
7493 cd            write (2,*) 'iii=2'
7494 cd            do jjj=1,2
7495 cd              write (2,'(3(2f10.5),5x)')
7496 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7497 cd            enddo
7498 cd          endif
7499         enddo
7500       enddo
7501       return
7502       end
7503 C---------------------------------------------------------------------------
7504       double precision function eello4(i,j,k,l,jj,kk)
7505       implicit real*8 (a-h,o-z)
7506       include 'DIMENSIONS'
7507       include 'COMMON.IOUNITS'
7508       include 'COMMON.CHAIN'
7509       include 'COMMON.DERIV'
7510       include 'COMMON.INTERACT'
7511       include 'COMMON.CONTACTS'
7512       include 'COMMON.TORSION'
7513       include 'COMMON.VAR'
7514       include 'COMMON.GEO'
7515       double precision pizda(2,2),ggg1(3),ggg2(3)
7516 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7517 cd        eello4=0.0d0
7518 cd        return
7519 cd      endif
7520 cd      print *,'eello4:',i,j,k,l,jj,kk
7521 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7522 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7523 cold      eij=facont_hb(jj,i)
7524 cold      ekl=facont_hb(kk,k)
7525 cold      ekont=eij*ekl
7526       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7527 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7528       gcorr_loc(k-1)=gcorr_loc(k-1)
7529      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7530       if (l.eq.j+1) then
7531         gcorr_loc(l-1)=gcorr_loc(l-1)
7532      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7533       else
7534         gcorr_loc(j-1)=gcorr_loc(j-1)
7535      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7536       endif
7537       do iii=1,2
7538         do kkk=1,5
7539           do lll=1,3
7540             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7541      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7542 cd            derx(lll,kkk,iii)=0.0d0
7543           enddo
7544         enddo
7545       enddo
7546 cd      gcorr_loc(l-1)=0.0d0
7547 cd      gcorr_loc(j-1)=0.0d0
7548 cd      gcorr_loc(k-1)=0.0d0
7549 cd      eel4=1.0d0
7550 cd      write (iout,*)'Contacts have occurred for peptide groups',
7551 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7552 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7553       if (j.lt.nres-1) then
7554         j1=j+1
7555         j2=j-1
7556       else
7557         j1=j-1
7558         j2=j-2
7559       endif
7560       if (l.lt.nres-1) then
7561         l1=l+1
7562         l2=l-1
7563       else
7564         l1=l-1
7565         l2=l-2
7566       endif
7567       do ll=1,3
7568 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7569 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7570         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7571         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7572 cgrad        ghalf=0.5d0*ggg1(ll)
7573         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7574         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7575         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7576         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7577         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7578         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7579 cgrad        ghalf=0.5d0*ggg2(ll)
7580         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7581         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7582         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7583         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7584         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7585         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7586       enddo
7587 cgrad      do m=i+1,j-1
7588 cgrad        do ll=1,3
7589 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7590 cgrad        enddo
7591 cgrad      enddo
7592 cgrad      do m=k+1,l-1
7593 cgrad        do ll=1,3
7594 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7595 cgrad        enddo
7596 cgrad      enddo
7597 cgrad      do m=i+2,j2
7598 cgrad        do ll=1,3
7599 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7600 cgrad        enddo
7601 cgrad      enddo
7602 cgrad      do m=k+2,l2
7603 cgrad        do ll=1,3
7604 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7605 cgrad        enddo
7606 cgrad      enddo
7607 cd      do iii=1,nres-3
7608 cd        write (2,*) iii,gcorr_loc(iii)
7609 cd      enddo
7610       eello4=ekont*eel4
7611 cd      write (2,*) 'ekont',ekont
7612 cd      write (iout,*) 'eello4',ekont*eel4
7613       return
7614       end
7615 C---------------------------------------------------------------------------
7616       double precision function eello5(i,j,k,l,jj,kk)
7617       implicit real*8 (a-h,o-z)
7618       include 'DIMENSIONS'
7619       include 'COMMON.IOUNITS'
7620       include 'COMMON.CHAIN'
7621       include 'COMMON.DERIV'
7622       include 'COMMON.INTERACT'
7623       include 'COMMON.CONTACTS'
7624       include 'COMMON.TORSION'
7625       include 'COMMON.VAR'
7626       include 'COMMON.GEO'
7627       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7628       double precision ggg1(3),ggg2(3)
7629 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7630 C                                                                              C
7631 C                            Parallel chains                                   C
7632 C                                                                              C
7633 C          o             o                   o             o                   C
7634 C         /l\           / \             \   / \           / \   /              C
7635 C        /   \         /   \             \ /   \         /   \ /               C
7636 C       j| o |l1       | o |              o| o |         | o |o                C
7637 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7638 C      \i/   \         /   \ /             /   \         /   \                 C
7639 C       o    k1             o                                                  C
7640 C         (I)          (II)                (III)          (IV)                 C
7641 C                                                                              C
7642 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7643 C                                                                              C
7644 C                            Antiparallel chains                               C
7645 C                                                                              C
7646 C          o             o                   o             o                   C
7647 C         /j\           / \             \   / \           / \   /              C
7648 C        /   \         /   \             \ /   \         /   \ /               C
7649 C      j1| o |l        | o |              o| o |         | o |o                C
7650 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7651 C      \i/   \         /   \ /             /   \         /   \                 C
7652 C       o     k1            o                                                  C
7653 C         (I)          (II)                (III)          (IV)                 C
7654 C                                                                              C
7655 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7656 C                                                                              C
7657 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7658 C                                                                              C
7659 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7660 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7661 cd        eello5=0.0d0
7662 cd        return
7663 cd      endif
7664 cd      write (iout,*)
7665 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7666 cd     &   ' and',k,l
7667       itk=itortyp(itype(k))
7668       itl=itortyp(itype(l))
7669       itj=itortyp(itype(j))
7670       eello5_1=0.0d0
7671       eello5_2=0.0d0
7672       eello5_3=0.0d0
7673       eello5_4=0.0d0
7674 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7675 cd     &   eel5_3_num,eel5_4_num)
7676       do iii=1,2
7677         do kkk=1,5
7678           do lll=1,3
7679             derx(lll,kkk,iii)=0.0d0
7680           enddo
7681         enddo
7682       enddo
7683 cd      eij=facont_hb(jj,i)
7684 cd      ekl=facont_hb(kk,k)
7685 cd      ekont=eij*ekl
7686 cd      write (iout,*)'Contacts have occurred for peptide groups',
7687 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7688 cd      goto 1111
7689 C Contribution from the graph I.
7690 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7691 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7692       call transpose2(EUg(1,1,k),auxmat(1,1))
7693       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7694       vv(1)=pizda(1,1)-pizda(2,2)
7695       vv(2)=pizda(1,2)+pizda(2,1)
7696       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7697      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7698 C Explicit gradient in virtual-dihedral angles.
7699       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7700      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7701      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7702       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7703       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7704       vv(1)=pizda(1,1)-pizda(2,2)
7705       vv(2)=pizda(1,2)+pizda(2,1)
7706       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7707      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7708      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7709       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7710       vv(1)=pizda(1,1)-pizda(2,2)
7711       vv(2)=pizda(1,2)+pizda(2,1)
7712       if (l.eq.j+1) then
7713         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7714      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7715      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7716       else
7717         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7718      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7719      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7720       endif
7721 C Cartesian gradient
7722       do iii=1,2
7723         do kkk=1,5
7724           do lll=1,3
7725             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7726      &        pizda(1,1))
7727             vv(1)=pizda(1,1)-pizda(2,2)
7728             vv(2)=pizda(1,2)+pizda(2,1)
7729             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7730      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7731      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7732           enddo
7733         enddo
7734       enddo
7735 c      goto 1112
7736 c1111  continue
7737 C Contribution from graph II
7738       call transpose2(EE(1,1,itk),auxmat(1,1))
7739       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7740       vv(1)=pizda(1,1)+pizda(2,2)
7741       vv(2)=pizda(2,1)-pizda(1,2)
7742       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7743      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7744 C Explicit gradient in virtual-dihedral angles.
7745       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7746      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7747       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7748       vv(1)=pizda(1,1)+pizda(2,2)
7749       vv(2)=pizda(2,1)-pizda(1,2)
7750       if (l.eq.j+1) then
7751         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7752      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7753      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7754       else
7755         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7756      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7757      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7758       endif
7759 C Cartesian gradient
7760       do iii=1,2
7761         do kkk=1,5
7762           do lll=1,3
7763             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7764      &        pizda(1,1))
7765             vv(1)=pizda(1,1)+pizda(2,2)
7766             vv(2)=pizda(2,1)-pizda(1,2)
7767             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7768      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7769      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7770           enddo
7771         enddo
7772       enddo
7773 cd      goto 1112
7774 cd1111  continue
7775       if (l.eq.j+1) then
7776 cd        goto 1110
7777 C Parallel orientation
7778 C Contribution from graph III
7779         call transpose2(EUg(1,1,l),auxmat(1,1))
7780         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7781         vv(1)=pizda(1,1)-pizda(2,2)
7782         vv(2)=pizda(1,2)+pizda(2,1)
7783         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7784      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7785 C Explicit gradient in virtual-dihedral angles.
7786         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7787      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7788      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7789         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7790         vv(1)=pizda(1,1)-pizda(2,2)
7791         vv(2)=pizda(1,2)+pizda(2,1)
7792         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7793      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7794      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7795         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7796         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7797         vv(1)=pizda(1,1)-pizda(2,2)
7798         vv(2)=pizda(1,2)+pizda(2,1)
7799         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7800      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7801      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7802 C Cartesian gradient
7803         do iii=1,2
7804           do kkk=1,5
7805             do lll=1,3
7806               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7807      &          pizda(1,1))
7808               vv(1)=pizda(1,1)-pizda(2,2)
7809               vv(2)=pizda(1,2)+pizda(2,1)
7810               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7811      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7812      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7813             enddo
7814           enddo
7815         enddo
7816 cd        goto 1112
7817 C Contribution from graph IV
7818 cd1110    continue
7819         call transpose2(EE(1,1,itl),auxmat(1,1))
7820         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7821         vv(1)=pizda(1,1)+pizda(2,2)
7822         vv(2)=pizda(2,1)-pizda(1,2)
7823         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7824      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7825 C Explicit gradient in virtual-dihedral angles.
7826         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7827      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7828         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7829         vv(1)=pizda(1,1)+pizda(2,2)
7830         vv(2)=pizda(2,1)-pizda(1,2)
7831         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7832      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7833      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7834 C Cartesian gradient
7835         do iii=1,2
7836           do kkk=1,5
7837             do lll=1,3
7838               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7839      &          pizda(1,1))
7840               vv(1)=pizda(1,1)+pizda(2,2)
7841               vv(2)=pizda(2,1)-pizda(1,2)
7842               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7843      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7844      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7845             enddo
7846           enddo
7847         enddo
7848       else
7849 C Antiparallel orientation
7850 C Contribution from graph III
7851 c        goto 1110
7852         call transpose2(EUg(1,1,j),auxmat(1,1))
7853         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7854         vv(1)=pizda(1,1)-pizda(2,2)
7855         vv(2)=pizda(1,2)+pizda(2,1)
7856         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7857      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7858 C Explicit gradient in virtual-dihedral angles.
7859         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7860      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7861      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7862         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7863         vv(1)=pizda(1,1)-pizda(2,2)
7864         vv(2)=pizda(1,2)+pizda(2,1)
7865         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7866      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7867      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7868         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7869         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7870         vv(1)=pizda(1,1)-pizda(2,2)
7871         vv(2)=pizda(1,2)+pizda(2,1)
7872         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7873      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7874      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7875 C Cartesian gradient
7876         do iii=1,2
7877           do kkk=1,5
7878             do lll=1,3
7879               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7880      &          pizda(1,1))
7881               vv(1)=pizda(1,1)-pizda(2,2)
7882               vv(2)=pizda(1,2)+pizda(2,1)
7883               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7884      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7885      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7886             enddo
7887           enddo
7888         enddo
7889 cd        goto 1112
7890 C Contribution from graph IV
7891 1110    continue
7892         call transpose2(EE(1,1,itj),auxmat(1,1))
7893         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7894         vv(1)=pizda(1,1)+pizda(2,2)
7895         vv(2)=pizda(2,1)-pizda(1,2)
7896         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7897      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7898 C Explicit gradient in virtual-dihedral angles.
7899         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7900      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7901         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7902         vv(1)=pizda(1,1)+pizda(2,2)
7903         vv(2)=pizda(2,1)-pizda(1,2)
7904         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7905      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7906      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7907 C Cartesian gradient
7908         do iii=1,2
7909           do kkk=1,5
7910             do lll=1,3
7911               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7912      &          pizda(1,1))
7913               vv(1)=pizda(1,1)+pizda(2,2)
7914               vv(2)=pizda(2,1)-pizda(1,2)
7915               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7916      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7917      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7918             enddo
7919           enddo
7920         enddo
7921       endif
7922 1112  continue
7923       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7924 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7925 cd        write (2,*) 'ijkl',i,j,k,l
7926 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7927 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7928 cd      endif
7929 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7930 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7931 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7932 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7933       if (j.lt.nres-1) then
7934         j1=j+1
7935         j2=j-1
7936       else
7937         j1=j-1
7938         j2=j-2
7939       endif
7940       if (l.lt.nres-1) then
7941         l1=l+1
7942         l2=l-1
7943       else
7944         l1=l-1
7945         l2=l-2
7946       endif
7947 cd      eij=1.0d0
7948 cd      ekl=1.0d0
7949 cd      ekont=1.0d0
7950 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7951 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7952 C        summed up outside the subrouine as for the other subroutines
7953 C        handling long-range interactions. The old code is commented out
7954 C        with "cgrad" to keep track of changes.
7955       do ll=1,3
7956 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7957 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7958         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7959         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7960 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7961 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7962 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7963 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7964 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7965 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7966 c     &   gradcorr5ij,
7967 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7968 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7969 cgrad        ghalf=0.5d0*ggg1(ll)
7970 cd        ghalf=0.0d0
7971         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7972         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7973         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7974         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7975         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7976         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7977 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7978 cgrad        ghalf=0.5d0*ggg2(ll)
7979 cd        ghalf=0.0d0
7980         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7981         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7982         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7983         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7984         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7985         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7986       enddo
7987 cd      goto 1112
7988 cgrad      do m=i+1,j-1
7989 cgrad        do ll=1,3
7990 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7991 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7992 cgrad        enddo
7993 cgrad      enddo
7994 cgrad      do m=k+1,l-1
7995 cgrad        do ll=1,3
7996 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7997 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7998 cgrad        enddo
7999 cgrad      enddo
8000 c1112  continue
8001 cgrad      do m=i+2,j2
8002 cgrad        do ll=1,3
8003 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
8004 cgrad        enddo
8005 cgrad      enddo
8006 cgrad      do m=k+2,l2
8007 cgrad        do ll=1,3
8008 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
8009 cgrad        enddo
8010 cgrad      enddo
8011 cd      do iii=1,nres-3
8012 cd        write (2,*) iii,g_corr5_loc(iii)
8013 cd      enddo
8014       eello5=ekont*eel5
8015 cd      write (2,*) 'ekont',ekont
8016 cd      write (iout,*) 'eello5',ekont*eel5
8017       return
8018       end
8019 c--------------------------------------------------------------------------
8020       double precision function eello6(i,j,k,l,jj,kk)
8021       implicit real*8 (a-h,o-z)
8022       include 'DIMENSIONS'
8023       include 'COMMON.IOUNITS'
8024       include 'COMMON.CHAIN'
8025       include 'COMMON.DERIV'
8026       include 'COMMON.INTERACT'
8027       include 'COMMON.CONTACTS'
8028       include 'COMMON.TORSION'
8029       include 'COMMON.VAR'
8030       include 'COMMON.GEO'
8031       include 'COMMON.FFIELD'
8032       double precision ggg1(3),ggg2(3)
8033 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8034 cd        eello6=0.0d0
8035 cd        return
8036 cd      endif
8037 cd      write (iout,*)
8038 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8039 cd     &   ' and',k,l
8040       eello6_1=0.0d0
8041       eello6_2=0.0d0
8042       eello6_3=0.0d0
8043       eello6_4=0.0d0
8044       eello6_5=0.0d0
8045       eello6_6=0.0d0
8046 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
8047 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
8048       do iii=1,2
8049         do kkk=1,5
8050           do lll=1,3
8051             derx(lll,kkk,iii)=0.0d0
8052           enddo
8053         enddo
8054       enddo
8055 cd      eij=facont_hb(jj,i)
8056 cd      ekl=facont_hb(kk,k)
8057 cd      ekont=eij*ekl
8058 cd      eij=1.0d0
8059 cd      ekl=1.0d0
8060 cd      ekont=1.0d0
8061       if (l.eq.j+1) then
8062         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8063         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
8064         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
8065         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8066         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
8067         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
8068       else
8069         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
8070         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
8071         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
8072         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
8073         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
8074           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8075         else
8076           eello6_5=0.0d0
8077         endif
8078         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
8079       endif
8080 C If turn contributions are considered, they will be handled separately.
8081       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8082 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8083 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8084 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8085 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8086 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8087 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8088 cd      goto 1112
8089       if (j.lt.nres-1) then
8090         j1=j+1
8091         j2=j-1
8092       else
8093         j1=j-1
8094         j2=j-2
8095       endif
8096       if (l.lt.nres-1) then
8097         l1=l+1
8098         l2=l-1
8099       else
8100         l1=l-1
8101         l2=l-2
8102       endif
8103       do ll=1,3
8104 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8105 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8106 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8107 cgrad        ghalf=0.5d0*ggg1(ll)
8108 cd        ghalf=0.0d0
8109         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8110         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8111         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8112         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8113         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8114         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8115         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8116         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8117 cgrad        ghalf=0.5d0*ggg2(ll)
8118 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8119 cd        ghalf=0.0d0
8120         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8121         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8122         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8123         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8124         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8125         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8126       enddo
8127 cd      goto 1112
8128 cgrad      do m=i+1,j-1
8129 cgrad        do ll=1,3
8130 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8131 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8132 cgrad        enddo
8133 cgrad      enddo
8134 cgrad      do m=k+1,l-1
8135 cgrad        do ll=1,3
8136 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8137 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8138 cgrad        enddo
8139 cgrad      enddo
8140 cgrad1112  continue
8141 cgrad      do m=i+2,j2
8142 cgrad        do ll=1,3
8143 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8144 cgrad        enddo
8145 cgrad      enddo
8146 cgrad      do m=k+2,l2
8147 cgrad        do ll=1,3
8148 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8149 cgrad        enddo
8150 cgrad      enddo
8151 cd      do iii=1,nres-3
8152 cd        write (2,*) iii,g_corr6_loc(iii)
8153 cd      enddo
8154       eello6=ekont*eel6
8155 cd      write (2,*) 'ekont',ekont
8156 cd      write (iout,*) 'eello6',ekont*eel6
8157       return
8158       end
8159 c--------------------------------------------------------------------------
8160       double precision function eello6_graph1(i,j,k,l,imat,swap)
8161       implicit real*8 (a-h,o-z)
8162       include 'DIMENSIONS'
8163       include 'COMMON.IOUNITS'
8164       include 'COMMON.CHAIN'
8165       include 'COMMON.DERIV'
8166       include 'COMMON.INTERACT'
8167       include 'COMMON.CONTACTS'
8168       include 'COMMON.TORSION'
8169       include 'COMMON.VAR'
8170       include 'COMMON.GEO'
8171       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8172       logical swap
8173       logical lprn
8174       common /kutas/ lprn
8175 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8176 C
8177 C      Parallel       Antiparallel
8178 C
8179 C          o             o
8180 C         /l\           /j\
8181 C        /   \         /   \
8182 C       /| o |         | o |\
8183 C     \ j|/k\|  /   \  |/k\|l /
8184 C      \ /   \ /     \ /   \ /
8185 C       o     o       o     o
8186 C       i             i
8187 C
8188 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8189       itk=itortyp(itype(k))
8190       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8191       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8192       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8193       call transpose2(EUgC(1,1,k),auxmat(1,1))
8194       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8195       vv1(1)=pizda1(1,1)-pizda1(2,2)
8196       vv1(2)=pizda1(1,2)+pizda1(2,1)
8197       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8198       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8199       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8200       s5=scalar2(vv(1),Dtobr2(1,i))
8201 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8202       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8203       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8204      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8205      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8206      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8207      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8208      & +scalar2(vv(1),Dtobr2der(1,i)))
8209       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8210       vv1(1)=pizda1(1,1)-pizda1(2,2)
8211       vv1(2)=pizda1(1,2)+pizda1(2,1)
8212       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8213       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8214       if (l.eq.j+1) then
8215         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8216      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8217      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8218      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8219      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8220       else
8221         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8222      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8223      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8224      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8225      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8226       endif
8227       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8228       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8229       vv1(1)=pizda1(1,1)-pizda1(2,2)
8230       vv1(2)=pizda1(1,2)+pizda1(2,1)
8231       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8232      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8233      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8234      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8235       do iii=1,2
8236         if (swap) then
8237           ind=3-iii
8238         else
8239           ind=iii
8240         endif
8241         do kkk=1,5
8242           do lll=1,3
8243             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8244             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8245             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8246             call transpose2(EUgC(1,1,k),auxmat(1,1))
8247             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8248      &        pizda1(1,1))
8249             vv1(1)=pizda1(1,1)-pizda1(2,2)
8250             vv1(2)=pizda1(1,2)+pizda1(2,1)
8251             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8252             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8253      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8254             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8255      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8256             s5=scalar2(vv(1),Dtobr2(1,i))
8257             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8258           enddo
8259         enddo
8260       enddo
8261       return
8262       end
8263 c----------------------------------------------------------------------------
8264       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8265       implicit real*8 (a-h,o-z)
8266       include 'DIMENSIONS'
8267       include 'COMMON.IOUNITS'
8268       include 'COMMON.CHAIN'
8269       include 'COMMON.DERIV'
8270       include 'COMMON.INTERACT'
8271       include 'COMMON.CONTACTS'
8272       include 'COMMON.TORSION'
8273       include 'COMMON.VAR'
8274       include 'COMMON.GEO'
8275       logical swap
8276       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8277      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8278       logical lprn
8279       common /kutas/ lprn
8280 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8281 C                                                                              C
8282 C      Parallel       Antiparallel                                             C
8283 C                                                                              C
8284 C          o             o                                                     C
8285 C     \   /l\           /j\   /                                                C
8286 C      \ /   \         /   \ /                                                 C
8287 C       o| o |         | o |o                                                  C
8288 C     \ j|/k\|      \  |/k\|l                                                  C
8289 C      \ /   \       \ /   \                                                   C
8290 C       o             o                                                        C
8291 C       i             i                                                        C
8292 C                                                                              C
8293 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8294 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8295 C AL 7/4/01 s1 would occur in the sixth-order moment,
8296 C           but not in a cluster cumulant
8297 #ifdef MOMENT
8298       s1=dip(1,jj,i)*dip(1,kk,k)
8299 #endif
8300       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8301       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8302       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8303       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8304       call transpose2(EUg(1,1,k),auxmat(1,1))
8305       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8306       vv(1)=pizda(1,1)-pizda(2,2)
8307       vv(2)=pizda(1,2)+pizda(2,1)
8308       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8309 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8310 #ifdef MOMENT
8311       eello6_graph2=-(s1+s2+s3+s4)
8312 #else
8313       eello6_graph2=-(s2+s3+s4)
8314 #endif
8315 c      eello6_graph2=-s3
8316 C Derivatives in gamma(i-1)
8317       if (i.gt.1) then
8318 #ifdef MOMENT
8319         s1=dipderg(1,jj,i)*dip(1,kk,k)
8320 #endif
8321         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8322         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8323         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8324         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8325 #ifdef MOMENT
8326         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8327 #else
8328         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8329 #endif
8330 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8331       endif
8332 C Derivatives in gamma(k-1)
8333 #ifdef MOMENT
8334       s1=dip(1,jj,i)*dipderg(1,kk,k)
8335 #endif
8336       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8337       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8338       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8339       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8340       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8341       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8342       vv(1)=pizda(1,1)-pizda(2,2)
8343       vv(2)=pizda(1,2)+pizda(2,1)
8344       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8345 #ifdef MOMENT
8346       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8347 #else
8348       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8349 #endif
8350 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8351 C Derivatives in gamma(j-1) or gamma(l-1)
8352       if (j.gt.1) then
8353 #ifdef MOMENT
8354         s1=dipderg(3,jj,i)*dip(1,kk,k)
8355 #endif
8356         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8357         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8358         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8359         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8360         vv(1)=pizda(1,1)-pizda(2,2)
8361         vv(2)=pizda(1,2)+pizda(2,1)
8362         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8363 #ifdef MOMENT
8364         if (swap) then
8365           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8366         else
8367           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8368         endif
8369 #endif
8370         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8371 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8372       endif
8373 C Derivatives in gamma(l-1) or gamma(j-1)
8374       if (l.gt.1) then
8375 #ifdef MOMENT
8376         s1=dip(1,jj,i)*dipderg(3,kk,k)
8377 #endif
8378         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8379         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8380         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8381         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8382         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8383         vv(1)=pizda(1,1)-pizda(2,2)
8384         vv(2)=pizda(1,2)+pizda(2,1)
8385         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8386 #ifdef MOMENT
8387         if (swap) then
8388           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8389         else
8390           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8391         endif
8392 #endif
8393         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8394 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8395       endif
8396 C Cartesian derivatives.
8397       if (lprn) then
8398         write (2,*) 'In eello6_graph2'
8399         do iii=1,2
8400           write (2,*) 'iii=',iii
8401           do kkk=1,5
8402             write (2,*) 'kkk=',kkk
8403             do jjj=1,2
8404               write (2,'(3(2f10.5),5x)')
8405      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8406             enddo
8407           enddo
8408         enddo
8409       endif
8410       do iii=1,2
8411         do kkk=1,5
8412           do lll=1,3
8413 #ifdef MOMENT
8414             if (iii.eq.1) then
8415               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8416             else
8417               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8418             endif
8419 #endif
8420             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8421      &        auxvec(1))
8422             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8423             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8424      &        auxvec(1))
8425             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8426             call transpose2(EUg(1,1,k),auxmat(1,1))
8427             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8428      &        pizda(1,1))
8429             vv(1)=pizda(1,1)-pizda(2,2)
8430             vv(2)=pizda(1,2)+pizda(2,1)
8431             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8432 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8433 #ifdef MOMENT
8434             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8435 #else
8436             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8437 #endif
8438             if (swap) then
8439               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8440             else
8441               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8442             endif
8443           enddo
8444         enddo
8445       enddo
8446       return
8447       end
8448 c----------------------------------------------------------------------------
8449       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8450       implicit real*8 (a-h,o-z)
8451       include 'DIMENSIONS'
8452       include 'COMMON.IOUNITS'
8453       include 'COMMON.CHAIN'
8454       include 'COMMON.DERIV'
8455       include 'COMMON.INTERACT'
8456       include 'COMMON.CONTACTS'
8457       include 'COMMON.TORSION'
8458       include 'COMMON.VAR'
8459       include 'COMMON.GEO'
8460       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8461       logical swap
8462 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8463 C                                                                              C
8464 C      Parallel       Antiparallel                                             C
8465 C                                                                              C
8466 C          o             o                                                     C
8467 C         /l\   /   \   /j\                                                    C
8468 C        /   \ /     \ /   \                                                   C
8469 C       /| o |o       o| o |\                                                  C
8470 C       j|/k\|  /      |/k\|l /                                                C
8471 C        /   \ /       /   \ /                                                 C
8472 C       /     o       /     o                                                  C
8473 C       i             i                                                        C
8474 C                                                                              C
8475 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8476 C
8477 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8478 C           energy moment and not to the cluster cumulant.
8479       iti=itortyp(itype(i))
8480       if (j.lt.nres-1) then
8481         itj1=itortyp(itype(j+1))
8482       else
8483         itj1=ntortyp+1
8484       endif
8485       itk=itortyp(itype(k))
8486       itk1=itortyp(itype(k+1))
8487       if (l.lt.nres-1) then
8488         itl1=itortyp(itype(l+1))
8489       else
8490         itl1=ntortyp+1
8491       endif
8492 #ifdef MOMENT
8493       s1=dip(4,jj,i)*dip(4,kk,k)
8494 #endif
8495       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8496       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8497       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8498       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8499       call transpose2(EE(1,1,itk),auxmat(1,1))
8500       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8501       vv(1)=pizda(1,1)+pizda(2,2)
8502       vv(2)=pizda(2,1)-pizda(1,2)
8503       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8504 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8505 cd     & "sum",-(s2+s3+s4)
8506 #ifdef MOMENT
8507       eello6_graph3=-(s1+s2+s3+s4)
8508 #else
8509       eello6_graph3=-(s2+s3+s4)
8510 #endif
8511 c      eello6_graph3=-s4
8512 C Derivatives in gamma(k-1)
8513       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8514       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8515       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8516       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8517 C Derivatives in gamma(l-1)
8518       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8519       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8520       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8521       vv(1)=pizda(1,1)+pizda(2,2)
8522       vv(2)=pizda(2,1)-pizda(1,2)
8523       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8524       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8525 C Cartesian derivatives.
8526       do iii=1,2
8527         do kkk=1,5
8528           do lll=1,3
8529 #ifdef MOMENT
8530             if (iii.eq.1) then
8531               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8532             else
8533               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8534             endif
8535 #endif
8536             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8537      &        auxvec(1))
8538             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8539             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8540      &        auxvec(1))
8541             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8542             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8543      &        pizda(1,1))
8544             vv(1)=pizda(1,1)+pizda(2,2)
8545             vv(2)=pizda(2,1)-pizda(1,2)
8546             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8547 #ifdef MOMENT
8548             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8549 #else
8550             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8551 #endif
8552             if (swap) then
8553               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8554             else
8555               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8556             endif
8557 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8558           enddo
8559         enddo
8560       enddo
8561       return
8562       end
8563 c----------------------------------------------------------------------------
8564       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8565       implicit real*8 (a-h,o-z)
8566       include 'DIMENSIONS'
8567       include 'COMMON.IOUNITS'
8568       include 'COMMON.CHAIN'
8569       include 'COMMON.DERIV'
8570       include 'COMMON.INTERACT'
8571       include 'COMMON.CONTACTS'
8572       include 'COMMON.TORSION'
8573       include 'COMMON.VAR'
8574       include 'COMMON.GEO'
8575       include 'COMMON.FFIELD'
8576       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8577      & auxvec1(2),auxmat1(2,2)
8578       logical swap
8579 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8580 C                                                                              C
8581 C      Parallel       Antiparallel                                             C
8582 C                                                                              C
8583 C          o             o                                                     C
8584 C         /l\   /   \   /j\                                                    C
8585 C        /   \ /     \ /   \                                                   C
8586 C       /| o |o       o| o |\                                                  C
8587 C     \ j|/k\|      \  |/k\|l                                                  C
8588 C      \ /   \       \ /   \                                                   C
8589 C       o     \       o     \                                                  C
8590 C       i             i                                                        C
8591 C                                                                              C
8592 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8593 C
8594 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8595 C           energy moment and not to the cluster cumulant.
8596 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8597       iti=itortyp(itype(i))
8598       itj=itortyp(itype(j))
8599       if (j.lt.nres-1) then
8600         itj1=itortyp(itype(j+1))
8601       else
8602         itj1=ntortyp+1
8603       endif
8604       itk=itortyp(itype(k))
8605       if (k.lt.nres-1) then
8606         itk1=itortyp(itype(k+1))
8607       else
8608         itk1=ntortyp+1
8609       endif
8610       itl=itortyp(itype(l))
8611       if (l.lt.nres-1) then
8612         itl1=itortyp(itype(l+1))
8613       else
8614         itl1=ntortyp+1
8615       endif
8616 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8617 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8618 cd     & ' itl',itl,' itl1',itl1
8619 #ifdef MOMENT
8620       if (imat.eq.1) then
8621         s1=dip(3,jj,i)*dip(3,kk,k)
8622       else
8623         s1=dip(2,jj,j)*dip(2,kk,l)
8624       endif
8625 #endif
8626       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8627       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8628       if (j.eq.l+1) then
8629         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8630         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8631       else
8632         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8633         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8634       endif
8635       call transpose2(EUg(1,1,k),auxmat(1,1))
8636       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8637       vv(1)=pizda(1,1)-pizda(2,2)
8638       vv(2)=pizda(2,1)+pizda(1,2)
8639       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8640 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8641 #ifdef MOMENT
8642       eello6_graph4=-(s1+s2+s3+s4)
8643 #else
8644       eello6_graph4=-(s2+s3+s4)
8645 #endif
8646 C Derivatives in gamma(i-1)
8647       if (i.gt.1) then
8648 #ifdef MOMENT
8649         if (imat.eq.1) then
8650           s1=dipderg(2,jj,i)*dip(3,kk,k)
8651         else
8652           s1=dipderg(4,jj,j)*dip(2,kk,l)
8653         endif
8654 #endif
8655         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8656         if (j.eq.l+1) then
8657           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8658           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8659         else
8660           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8661           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8662         endif
8663         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8664         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8665 cd          write (2,*) 'turn6 derivatives'
8666 #ifdef MOMENT
8667           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8668 #else
8669           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8670 #endif
8671         else
8672 #ifdef MOMENT
8673           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8674 #else
8675           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8676 #endif
8677         endif
8678       endif
8679 C Derivatives in gamma(k-1)
8680 #ifdef MOMENT
8681       if (imat.eq.1) then
8682         s1=dip(3,jj,i)*dipderg(2,kk,k)
8683       else
8684         s1=dip(2,jj,j)*dipderg(4,kk,l)
8685       endif
8686 #endif
8687       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8688       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8689       if (j.eq.l+1) then
8690         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8691         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8692       else
8693         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8694         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8695       endif
8696       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8697       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8698       vv(1)=pizda(1,1)-pizda(2,2)
8699       vv(2)=pizda(2,1)+pizda(1,2)
8700       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8701       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8702 #ifdef MOMENT
8703         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8704 #else
8705         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8706 #endif
8707       else
8708 #ifdef MOMENT
8709         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8710 #else
8711         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8712 #endif
8713       endif
8714 C Derivatives in gamma(j-1) or gamma(l-1)
8715       if (l.eq.j+1 .and. l.gt.1) then
8716         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8717         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8718         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8719         vv(1)=pizda(1,1)-pizda(2,2)
8720         vv(2)=pizda(2,1)+pizda(1,2)
8721         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8722         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8723       else if (j.gt.1) then
8724         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8725         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8726         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8727         vv(1)=pizda(1,1)-pizda(2,2)
8728         vv(2)=pizda(2,1)+pizda(1,2)
8729         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8730         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8731           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8732         else
8733           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8734         endif
8735       endif
8736 C Cartesian derivatives.
8737       do iii=1,2
8738         do kkk=1,5
8739           do lll=1,3
8740 #ifdef MOMENT
8741             if (iii.eq.1) then
8742               if (imat.eq.1) then
8743                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8744               else
8745                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8746               endif
8747             else
8748               if (imat.eq.1) then
8749                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8750               else
8751                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8752               endif
8753             endif
8754 #endif
8755             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8756      &        auxvec(1))
8757             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8758             if (j.eq.l+1) then
8759               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8760      &          b1(1,itj1),auxvec(1))
8761               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8762             else
8763               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8764      &          b1(1,itl1),auxvec(1))
8765               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8766             endif
8767             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8768      &        pizda(1,1))
8769             vv(1)=pizda(1,1)-pizda(2,2)
8770             vv(2)=pizda(2,1)+pizda(1,2)
8771             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8772             if (swap) then
8773               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8774 #ifdef MOMENT
8775                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8776      &             -(s1+s2+s4)
8777 #else
8778                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8779      &             -(s2+s4)
8780 #endif
8781                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8782               else
8783 #ifdef MOMENT
8784                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8785 #else
8786                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8787 #endif
8788                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8789               endif
8790             else
8791 #ifdef MOMENT
8792               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8793 #else
8794               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8795 #endif
8796               if (l.eq.j+1) then
8797                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8798               else
8799                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8800               endif
8801             endif
8802           enddo
8803         enddo
8804       enddo
8805       return
8806       end
8807 c----------------------------------------------------------------------------
8808       double precision function eello_turn6(i,jj,kk)
8809       implicit real*8 (a-h,o-z)
8810       include 'DIMENSIONS'
8811       include 'COMMON.IOUNITS'
8812       include 'COMMON.CHAIN'
8813       include 'COMMON.DERIV'
8814       include 'COMMON.INTERACT'
8815       include 'COMMON.CONTACTS'
8816       include 'COMMON.TORSION'
8817       include 'COMMON.VAR'
8818       include 'COMMON.GEO'
8819       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8820      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8821      &  ggg1(3),ggg2(3)
8822       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8823      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8824 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8825 C           the respective energy moment and not to the cluster cumulant.
8826       s1=0.0d0
8827       s8=0.0d0
8828       s13=0.0d0
8829 c
8830       eello_turn6=0.0d0
8831       j=i+4
8832       k=i+1
8833       l=i+3
8834       iti=itortyp(itype(i))
8835       itk=itortyp(itype(k))
8836       itk1=itortyp(itype(k+1))
8837       itl=itortyp(itype(l))
8838       itj=itortyp(itype(j))
8839 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8840 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8841 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8842 cd        eello6=0.0d0
8843 cd        return
8844 cd      endif
8845 cd      write (iout,*)
8846 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8847 cd     &   ' and',k,l
8848 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8849       do iii=1,2
8850         do kkk=1,5
8851           do lll=1,3
8852             derx_turn(lll,kkk,iii)=0.0d0
8853           enddo
8854         enddo
8855       enddo
8856 cd      eij=1.0d0
8857 cd      ekl=1.0d0
8858 cd      ekont=1.0d0
8859       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8860 cd      eello6_5=0.0d0
8861 cd      write (2,*) 'eello6_5',eello6_5
8862 #ifdef MOMENT
8863       call transpose2(AEA(1,1,1),auxmat(1,1))
8864       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8865       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8866       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8867 #endif
8868       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8869       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8870       s2 = scalar2(b1(1,itk),vtemp1(1))
8871 #ifdef MOMENT
8872       call transpose2(AEA(1,1,2),atemp(1,1))
8873       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8874       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8875       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8876 #endif
8877       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8878       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8879       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8880 #ifdef MOMENT
8881       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8882       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8883       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8884       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8885       ss13 = scalar2(b1(1,itk),vtemp4(1))
8886       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8887 #endif
8888 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8889 c      s1=0.0d0
8890 c      s2=0.0d0
8891 c      s8=0.0d0
8892 c      s12=0.0d0
8893 c      s13=0.0d0
8894       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8895 C Derivatives in gamma(i+2)
8896       s1d =0.0d0
8897       s8d =0.0d0
8898 #ifdef MOMENT
8899       call transpose2(AEA(1,1,1),auxmatd(1,1))
8900       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8901       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8902       call transpose2(AEAderg(1,1,2),atempd(1,1))
8903       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8904       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8905 #endif
8906       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8907       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8908       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8909 c      s1d=0.0d0
8910 c      s2d=0.0d0
8911 c      s8d=0.0d0
8912 c      s12d=0.0d0
8913 c      s13d=0.0d0
8914       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8915 C Derivatives in gamma(i+3)
8916 #ifdef MOMENT
8917       call transpose2(AEA(1,1,1),auxmatd(1,1))
8918       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8919       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8920       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8921 #endif
8922       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8923       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8924       s2d = scalar2(b1(1,itk),vtemp1d(1))
8925 #ifdef MOMENT
8926       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8927       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8928 #endif
8929       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8930 #ifdef MOMENT
8931       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8932       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8933       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8934 #endif
8935 c      s1d=0.0d0
8936 c      s2d=0.0d0
8937 c      s8d=0.0d0
8938 c      s12d=0.0d0
8939 c      s13d=0.0d0
8940 #ifdef MOMENT
8941       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8942      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8943 #else
8944       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8945      &               -0.5d0*ekont*(s2d+s12d)
8946 #endif
8947 C Derivatives in gamma(i+4)
8948       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8949       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8950       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8951 #ifdef MOMENT
8952       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8953       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8954       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8955 #endif
8956 c      s1d=0.0d0
8957 c      s2d=0.0d0
8958 c      s8d=0.0d0
8959 C      s12d=0.0d0
8960 c      s13d=0.0d0
8961 #ifdef MOMENT
8962       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8963 #else
8964       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8965 #endif
8966 C Derivatives in gamma(i+5)
8967 #ifdef MOMENT
8968       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8969       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8970       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8971 #endif
8972       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8973       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8974       s2d = scalar2(b1(1,itk),vtemp1d(1))
8975 #ifdef MOMENT
8976       call transpose2(AEA(1,1,2),atempd(1,1))
8977       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8978       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8979 #endif
8980       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8981       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8982 #ifdef MOMENT
8983       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8984       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8985       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8986 #endif
8987 c      s1d=0.0d0
8988 c      s2d=0.0d0
8989 c      s8d=0.0d0
8990 c      s12d=0.0d0
8991 c      s13d=0.0d0
8992 #ifdef MOMENT
8993       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8994      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8995 #else
8996       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8997      &               -0.5d0*ekont*(s2d+s12d)
8998 #endif
8999 C Cartesian derivatives
9000       do iii=1,2
9001         do kkk=1,5
9002           do lll=1,3
9003 #ifdef MOMENT
9004             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
9005             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
9006             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
9007 #endif
9008             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
9009             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
9010      &          vtemp1d(1))
9011             s2d = scalar2(b1(1,itk),vtemp1d(1))
9012 #ifdef MOMENT
9013             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
9014             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
9015             s8d = -(atempd(1,1)+atempd(2,2))*
9016      &           scalar2(cc(1,1,itl),vtemp2(1))
9017 #endif
9018             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
9019      &           auxmatd(1,1))
9020             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
9021             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
9022 c      s1d=0.0d0
9023 c      s2d=0.0d0
9024 c      s8d=0.0d0
9025 c      s12d=0.0d0
9026 c      s13d=0.0d0
9027 #ifdef MOMENT
9028             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9029      &        - 0.5d0*(s1d+s2d)
9030 #else
9031             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
9032      &        - 0.5d0*s2d
9033 #endif
9034 #ifdef MOMENT
9035             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9036      &        - 0.5d0*(s8d+s12d)
9037 #else
9038             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
9039      &        - 0.5d0*s12d
9040 #endif
9041           enddo
9042         enddo
9043       enddo
9044 #ifdef MOMENT
9045       do kkk=1,5
9046         do lll=1,3
9047           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
9048      &      achuj_tempd(1,1))
9049           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
9050           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
9051           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
9052           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
9053           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
9054      &      vtemp4d(1))
9055           ss13d = scalar2(b1(1,itk),vtemp4d(1))
9056           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
9057           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
9058         enddo
9059       enddo
9060 #endif
9061 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
9062 cd     &  16*eel_turn6_num
9063 cd      goto 1112
9064       if (j.lt.nres-1) then
9065         j1=j+1
9066         j2=j-1
9067       else
9068         j1=j-1
9069         j2=j-2
9070       endif
9071       if (l.lt.nres-1) then
9072         l1=l+1
9073         l2=l-1
9074       else
9075         l1=l-1
9076         l2=l-2
9077       endif
9078       do ll=1,3
9079 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
9080 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9081 cgrad        ghalf=0.5d0*ggg1(ll)
9082 cd        ghalf=0.0d0
9083         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9084         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9085         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9086      &    +ekont*derx_turn(ll,2,1)
9087         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9088         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9089      &    +ekont*derx_turn(ll,4,1)
9090         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9091         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9092         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9093 cgrad        ghalf=0.5d0*ggg2(ll)
9094 cd        ghalf=0.0d0
9095         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9096      &    +ekont*derx_turn(ll,2,2)
9097         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9098         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9099      &    +ekont*derx_turn(ll,4,2)
9100         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9101         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9102         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9103       enddo
9104 cd      goto 1112
9105 cgrad      do m=i+1,j-1
9106 cgrad        do ll=1,3
9107 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9108 cgrad        enddo
9109 cgrad      enddo
9110 cgrad      do m=k+1,l-1
9111 cgrad        do ll=1,3
9112 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9113 cgrad        enddo
9114 cgrad      enddo
9115 cgrad1112  continue
9116 cgrad      do m=i+2,j2
9117 cgrad        do ll=1,3
9118 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9119 cgrad        enddo
9120 cgrad      enddo
9121 cgrad      do m=k+2,l2
9122 cgrad        do ll=1,3
9123 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9124 cgrad        enddo
9125 cgrad      enddo
9126 cd      do iii=1,nres-3
9127 cd        write (2,*) iii,g_corr6_loc(iii)
9128 cd      enddo
9129       eello_turn6=ekont*eel_turn6
9130 cd      write (2,*) 'ekont',ekont
9131 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9132       return
9133       end
9134
9135 C-----------------------------------------------------------------------------
9136       double precision function scalar(u,v)
9137 !DIR$ INLINEALWAYS scalar
9138 #ifndef OSF
9139 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9140 #endif
9141       implicit none
9142       double precision u(3),v(3)
9143 cd      double precision sc
9144 cd      integer i
9145 cd      sc=0.0d0
9146 cd      do i=1,3
9147 cd        sc=sc+u(i)*v(i)
9148 cd      enddo
9149 cd      scalar=sc
9150
9151       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9152       return
9153       end
9154 crc-------------------------------------------------
9155       SUBROUTINE MATVEC2(A1,V1,V2)
9156 !DIR$ INLINEALWAYS MATVEC2
9157 #ifndef OSF
9158 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9159 #endif
9160       implicit real*8 (a-h,o-z)
9161       include 'DIMENSIONS'
9162       DIMENSION A1(2,2),V1(2),V2(2)
9163 c      DO 1 I=1,2
9164 c        VI=0.0
9165 c        DO 3 K=1,2
9166 c    3     VI=VI+A1(I,K)*V1(K)
9167 c        Vaux(I)=VI
9168 c    1 CONTINUE
9169
9170       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9171       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9172
9173       v2(1)=vaux1
9174       v2(2)=vaux2
9175       END
9176 C---------------------------------------
9177       SUBROUTINE MATMAT2(A1,A2,A3)
9178 #ifndef OSF
9179 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9180 #endif
9181       implicit real*8 (a-h,o-z)
9182       include 'DIMENSIONS'
9183       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9184 c      DIMENSION AI3(2,2)
9185 c        DO  J=1,2
9186 c          A3IJ=0.0
9187 c          DO K=1,2
9188 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9189 c          enddo
9190 c          A3(I,J)=A3IJ
9191 c       enddo
9192 c      enddo
9193
9194       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9195       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9196       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9197       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9198
9199       A3(1,1)=AI3_11
9200       A3(2,1)=AI3_21
9201       A3(1,2)=AI3_12
9202       A3(2,2)=AI3_22
9203       END
9204
9205 c-------------------------------------------------------------------------
9206       double precision function scalar2(u,v)
9207 !DIR$ INLINEALWAYS scalar2
9208       implicit none
9209       double precision u(2),v(2)
9210       double precision sc
9211       integer i
9212       scalar2=u(1)*v(1)+u(2)*v(2)
9213       return
9214       end
9215
9216 C-----------------------------------------------------------------------------
9217
9218       subroutine transpose2(a,at)
9219 !DIR$ INLINEALWAYS transpose2
9220 #ifndef OSF
9221 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9222 #endif
9223       implicit none
9224       double precision a(2,2),at(2,2)
9225       at(1,1)=a(1,1)
9226       at(1,2)=a(2,1)
9227       at(2,1)=a(1,2)
9228       at(2,2)=a(2,2)
9229       return
9230       end
9231 c--------------------------------------------------------------------------
9232       subroutine transpose(n,a,at)
9233       implicit none
9234       integer n,i,j
9235       double precision a(n,n),at(n,n)
9236       do i=1,n
9237         do j=1,n
9238           at(j,i)=a(i,j)
9239         enddo
9240       enddo
9241       return
9242       end
9243 C---------------------------------------------------------------------------
9244       subroutine prodmat3(a1,a2,kk,transp,prod)
9245 !DIR$ INLINEALWAYS prodmat3
9246 #ifndef OSF
9247 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9248 #endif
9249       implicit none
9250       integer i,j
9251       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9252       logical transp
9253 crc      double precision auxmat(2,2),prod_(2,2)
9254
9255       if (transp) then
9256 crc        call transpose2(kk(1,1),auxmat(1,1))
9257 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9258 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9259
9260            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9261      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9262            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9263      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9264            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9265      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9266            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9267      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9268
9269       else
9270 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9271 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9272
9273            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9274      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9275            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9276      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9277            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9278      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9279            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9280      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9281
9282       endif
9283 c      call transpose2(a2(1,1),a2t(1,1))
9284
9285 crc      print *,transp
9286 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9287 crc      print *,((prod(i,j),i=1,2),j=1,2)
9288
9289       return
9290       end
9291