source/unres/src_MD-M/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         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 c      print *,"Processor",myrank," computed USCSC"
 125 #ifdef TIMING
 126       time01=MPI_Wtime()
 127 #endif
 128       call vec_and_deriv
 129 #ifdef TIMING
 130       time_vec=time_vec+MPI_Wtime()-time01
 131 #endif
 132 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 133       if (ipot.lt.6) then
 134 #ifdef SPLITELE
 135          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 136      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 137      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 138      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 139 #else
 140          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #endif
 145             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 146          else
 147             ees=0.0d0
 148             evdw1=0.0d0
 149             eel_loc=0.0d0
 150             eello_turn3=0.0d0
 151             eello_turn4=0.0d0
 152          endif
 153       else
 154 c        write (iout,*) "Soft-spheer ELEC potential"
 155         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 156      &   eello_turn4)
 157       endif
 158 c      print *,"Processor",myrank," computed UELEC"
 159 C
 160 C Calculate excluded-volume interaction energy between peptide groups
 161 C and side chains.
 162 C
 163       if (ipot.lt.6) then
 164        if(wscp.gt.0d0) then
 165         call escp(evdw2,evdw2_14)
 166        else
 167         evdw2=0
 168         evdw2_14=0
 169        endif
 170       else
 171 c        write (iout,*) "Soft-sphere SCP potential"
 172         call escp_soft_sphere(evdw2,evdw2_14)
 173       endif
 174 c
 175 c Calculate the bond-stretching energy
 176 c
 177       call ebond(estr)
 178 C
 179 C Calculate the disulfide-bridge and other energy and the contributions
 180 C from other distance constraints.
 181 cd    print *,'Calling EHPB'
 182       call edis(ehpb)
 183 cd    print *,'EHPB exitted succesfully.'
 184 C
 185 C Calculate the virtual-bond-angle energy.
 186 C
 187       if (wang.gt.0d0) then
 188         call ebend(ebe)
 189       else
 190         ebe=0
 191       endif
 192 c      print *,"Processor",myrank," computed UB"
 193 C
 194 C Calculate the SC local energy.
 195 C
 196       call esc(escloc)
 197 c      print *,"Processor",myrank," computed USC"
 198 C
 199 C Calculate the virtual-bond torsional energy.
 200 C
 201 cd    print *,'nterm=',nterm
 202       if (wtor.gt.0) then
 203        call etor(etors,edihcnstr)
 204       else
 205        etors=0
 206        edihcnstr=0
 207       endif
 208 c      print *,"Processor",myrank," computed Utor"
 209 C
 210 C 6/23/01 Calculate double-torsional energy
 211 C
 212       if (wtor_d.gt.0) then
 213        call etor_d(etors_d)
 214       else
 215        etors_d=0
 216       endif
 217 c      print *,"Processor",myrank," computed Utord"
 218 C
 219 C 21/5/07 Calculate local sicdechain correlation energy
 220 C
 221       if (wsccor.gt.0.0d0) then
 222         call eback_sc_corr(esccor)
 223       else
 224         esccor=0.0d0
 225       endif
 226 c      print *,"Processor",myrank," computed Usccorr"
 227 C
 228 C 12/1/95 Multi-body terms
 229 C
 230       n_corr=0
 231       n_corr1=0
 232       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 233      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 234          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 235 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 236 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 237       else
 238          ecorr=0.0d0
 239          ecorr5=0.0d0
 240          ecorr6=0.0d0
 241          eturn6=0.0d0
 242       endif
 243       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 244          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 245 cd         write (iout,*) "multibody_hb ecorr",ecorr
 246       endif
 247 c      print *,"Processor",myrank," computed Ucorr"
 248 C
 249 C If performing constraint dynamics, call the constraint energy
 250 C  after the equilibration time
 251       if(usampl.and.totT.gt.eq_time) then
 252          call EconstrQ
 253          call Econstr_back
 254       else
 255          Uconst=0.0d0
 256          Uconst_back=0.0d0
 257       endif
 258 #ifdef TIMING
 259       time_enecalc=time_enecalc+MPI_Wtime()-time00
 260 #endif
 261 c      print *,"Processor",myrank," computed Uconstr"
 262 #ifdef TIMING
 263       time00=MPI_Wtime()
 264 #endif
 265 c
 266 C Sum the energies
 267 C
 268       energia(1)=evdw
 269 #ifdef SCP14
 270       energia(2)=evdw2-evdw2_14
 271       energia(18)=evdw2_14
 272 #else
 273       energia(2)=evdw2
 274       energia(18)=0.0d0
 275 #endif
 276 #ifdef SPLITELE
 277       energia(3)=ees
 278       energia(16)=evdw1
 279 #else
 280       energia(3)=ees+evdw1
 281       energia(16)=0.0d0
 282 #endif
 283       energia(4)=ecorr
 284       energia(5)=ecorr5
 285       energia(6)=ecorr6
 286       energia(7)=eel_loc
 287       energia(8)=eello_turn3
 288       energia(9)=eello_turn4
 289       energia(10)=eturn6
 290       energia(11)=ebe
 291       energia(12)=escloc
 292       energia(13)=etors
 293       energia(14)=etors_d
 294       energia(15)=ehpb
 295       energia(19)=edihcnstr
 296       energia(17)=estr
 297       energia(20)=Uconst+Uconst_back
 298       energia(21)=esccor
 299 c      print *," Processor",myrank," calls SUM_ENERGY"
 300       call sum_energy(energia,.true.)
 301 c      print *," Processor",myrank," left SUM_ENERGY"
 302 #ifdef TIMING
 303       time_sumene=time_sumene+MPI_Wtime()-time00
 304 #endif
 305       return
 306       end
 307 c-------------------------------------------------------------------------------
 308       subroutine sum_energy(energia,reduce)
 309       implicit real*8 (a-h,o-z)
 310       include 'DIMENSIONS'
 311 #ifndef ISNAN
 312       external proc_proc
 313 #ifdef WINPGI
 314 cMS$ATTRIBUTES C ::  proc_proc
 315 #endif
 316 #endif
 317 #ifdef MPI
 318       include "mpif.h"
 319 #endif
 320       include 'COMMON.SETUP'
 321       include 'COMMON.IOUNITS'
 322       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 323       include 'COMMON.FFIELD'
 324       include 'COMMON.DERIV'
 325       include 'COMMON.INTERACT'
 326       include 'COMMON.SBRIDGE'
 327       include 'COMMON.CHAIN'
 328       include 'COMMON.VAR'
 329       include 'COMMON.CONTROL'
 330       include 'COMMON.TIME1'
 331       logical reduce
 332 #ifdef MPI
 333       if (nfgtasks.gt.1 .and. reduce) then
 334 #ifdef DEBUG
 335         write (iout,*) "energies before REDUCE"
 336         call enerprint(energia)
 337         call flush(iout)
 338 #endif
 339         do i=0,n_ene
 340           enebuff(i)=energia(i)
 341         enddo
 342         time00=MPI_Wtime()
 343         call MPI_Barrier(FG_COMM,IERR)
 344         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 345         time00=MPI_Wtime()
 346         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 347      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 348 #ifdef DEBUG
 349         write (iout,*) "energies after REDUCE"
 350         call enerprint(energia)
 351         call flush(iout)
 352 #endif
 353         time_Reduce=time_Reduce+MPI_Wtime()-time00
 354       endif
 355       if (fg_rank.eq.0) then
 356 #endif
 357       evdw=energia(1)
 358 #ifdef SCP14
 359       evdw2=energia(2)+energia(18)
 360       evdw2_14=energia(18)
 361 #else
 362       evdw2=energia(2)
 363 #endif
 364 #ifdef SPLITELE
 365       ees=energia(3)
 366       evdw1=energia(16)
 367 #else
 368       ees=energia(3)
 369       evdw1=0.0d0
 370 #endif
 371       ecorr=energia(4)
 372       ecorr5=energia(5)
 373       ecorr6=energia(6)
 374       eel_loc=energia(7)
 375       eello_turn3=energia(8)
 376       eello_turn4=energia(9)
 377       eturn6=energia(10)
 378       ebe=energia(11)
 379       escloc=energia(12)
 380       etors=energia(13)
 381       etors_d=energia(14)
 382       ehpb=energia(15)
 383       edihcnstr=energia(19)
 384       estr=energia(17)
 385       Uconst=energia(20)
 386       esccor=energia(21)
 387 #ifdef SPLITELE
 388       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 389      & +wang*ebe+wtor*etors+wscloc*escloc
 390      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 391      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 392      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 393      & +wbond*estr+Uconst+wsccor*esccor
 394 #else
 395       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 396      & +wang*ebe+wtor*etors+wscloc*escloc
 397      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 398      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 399      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 400      & +wbond*estr+Uconst+wsccor*esccor
 401 #endif
 402       energia(0)=etot
 403 c detecting NaNQ
 404 #ifdef ISNAN
 405 #ifdef AIX
 406       if (isnan(etot).ne.0) energia(0)=1.0d+99
 407 #else
 408       if (isnan(etot)) energia(0)=1.0d+99
 409 #endif
 410 #else
 411       i=0
 412 #ifdef WINPGI
 413       idumm=proc_proc(etot,i)
 414 #else
 415       call proc_proc(etot,i)
 416 #endif
 417       if(i.eq.1)energia(0)=1.0d+99
 418 #endif
 419 #ifdef MPI
 420       endif
 421 #endif
 422       return
 423       end
 424 c-------------------------------------------------------------------------------
 425       subroutine sum_gradient
 426       implicit real*8 (a-h,o-z)
 427       include 'DIMENSIONS'
 428 #ifndef ISNAN
 429       external proc_proc
 430 #ifdef WINPGI
 431 cMS$ATTRIBUTES C ::  proc_proc
 432 #endif
 433 #endif
 434 #ifdef MPI
 435       include 'mpif.h'
 436       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 437      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 438 #endif
 439       include 'COMMON.SETUP'
 440       include 'COMMON.IOUNITS'
 441       include 'COMMON.FFIELD'
 442       include 'COMMON.DERIV'
 443       include 'COMMON.INTERACT'
 444       include 'COMMON.SBRIDGE'
 445       include 'COMMON.CHAIN'
 446       include 'COMMON.VAR'
 447       include 'COMMON.CONTROL'
 448       include 'COMMON.TIME1'
 449       include 'COMMON.MAXGRAD'
 450 #ifdef TIMING
 451       time01=MPI_Wtime()
 452 #endif
 453 #ifdef DEBUG
 454       write (iout,*) "sum_gradient gvdwc, gvdwx"
 455       do i=1,nres
 456         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 457      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 458       enddo
 459       call flush(iout)
 460 #endif
 461 #ifdef MPI
 462 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 463         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 464      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 465 #endif
 466 C
 467 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 468 C            in virtual-bond-vector coordinates
 469 C
 470 #ifdef DEBUG
 471 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 472 c      do i=1,nres-1
 473 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 474 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 475 c      enddo
 476 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 477 c      do i=1,nres-1
 478 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 479 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 480 c      enddo
 481       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 482       do i=1,nres
 483         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 484      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 485      &   g_corr5_loc(i)
 486       enddo
 487       call flush(iout)
 488 #endif
 489 #ifdef SPLITELE
 490       do i=1,nct
 491         do j=1,3
 492           gradbufc(j,i)=wsc*gvdwc(j,i)+
 493      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 494      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 495      &                wel_loc*gel_loc_long(j,i)+
 496      &                wcorr*gradcorr_long(j,i)+
 497      &                wcorr5*gradcorr5_long(j,i)+
 498      &                wcorr6*gradcorr6_long(j,i)+
 499      &                wturn6*gcorr6_turn_long(j,i)+
 500      &                wstrain*ghpbc(j,i)
 501         enddo
 502       enddo
 503 #else
 504       do i=1,nct
 505         do j=1,3
 506           gradbufc(j,i)=wsc*gvdwc(j,i)+
 507      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 508      &                welec*gelc_long(j,i)+
 509      &                wbond*gradb(j,i)+
 510      &                wel_loc*gel_loc_long(j,i)+
 511      &                wcorr*gradcorr_long(j,i)+
 512      &                wcorr5*gradcorr5_long(j,i)+
 513      &                wcorr6*gradcorr6_long(j,i)+
 514      &                wturn6*gcorr6_turn_long(j,i)+
 515      &                wstrain*ghpbc(j,i)
 516         enddo
 517       enddo
 518 #endif
 519 #ifdef MPI
 520       if (nfgtasks.gt.1) then
 521       time00=MPI_Wtime()
 522 #ifdef DEBUG
 523       write (iout,*) "gradbufc before allreduce"
 524       do i=1,nres
 525         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 526       enddo
 527       call flush(iout)
 528 #endif
 529       do i=1,nres
 530         do j=1,3
 531           gradbufc_sum(j,i)=gradbufc(j,i)
 532         enddo
 533       enddo
 534 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 535 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 536 c      time_reduce=time_reduce+MPI_Wtime()-time00
 537 #ifdef DEBUG
 538 c      write (iout,*) "gradbufc_sum after allreduce"
 539 c      do i=1,nres
 540 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 541 c      enddo
 542 c      call flush(iout)
 543 #endif
 544 #ifdef TIMING
 545 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 546 #endif
 547       do i=nnt,nres
 548         do k=1,3
 549           gradbufc(k,i)=0.0d0
 550         enddo
 551       enddo
 552 #ifdef DEBUG
 553       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 554       write (iout,*) (i," jgrad_start",jgrad_start(i),
 555      &                  " jgrad_end  ",jgrad_end(i),
 556      &                  i=igrad_start,igrad_end)
 557 #endif
 558 c
 559 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 560 c do not parallelize this part.
 561 c
 562 c      do i=igrad_start,igrad_end
 563 c        do j=jgrad_start(i),jgrad_end(i)
 564 c          do k=1,3
 565 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 566 c          enddo
 567 c        enddo
 568 c      enddo
 569       do j=1,3
 570         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 571       enddo
 572       do i=nres-2,nnt,-1
 573         do j=1,3
 574           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 575         enddo
 576       enddo
 577 #ifdef DEBUG
 578       write (iout,*) "gradbufc after summing"
 579       do i=1,nres
 580         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 581       enddo
 582       call flush(iout)
 583 #endif
 584       else
 585 #endif
 586 #ifdef DEBUG
 587       write (iout,*) "gradbufc"
 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           gradbufc(j,i)=0.0d0
 597         enddo
 598       enddo
 599       do j=1,3
 600         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 601       enddo
 602       do i=nres-2,nnt,-1
 603         do j=1,3
 604           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 605         enddo
 606       enddo
 607 c      do i=nnt,nres-1
 608 c        do k=1,3
 609 c          gradbufc(k,i)=0.0d0
 610 c        enddo
 611 c        do j=i+1,nres
 612 c          do k=1,3
 613 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 614 c          enddo
 615 c        enddo
 616 c      enddo
 617 #ifdef DEBUG
 618       write (iout,*) "gradbufc after summing"
 619       do i=1,nres
 620         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 621       enddo
 622       call flush(iout)
 623 #endif
 624 #ifdef MPI
 625       endif
 626 #endif
 627       do k=1,3
 628         gradbufc(k,nres)=0.0d0
 629       enddo
 630       do i=1,nct
 631         do j=1,3
 632 #ifdef SPLITELE
 633           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 634      &                wel_loc*gel_loc(j,i)+
 635      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 636      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 637      &                wel_loc*gel_loc_long(j,i)+
 638      &                wcorr*gradcorr_long(j,i)+
 639      &                wcorr5*gradcorr5_long(j,i)+
 640      &                wcorr6*gradcorr6_long(j,i)+
 641      &                wturn6*gcorr6_turn_long(j,i))+
 642      &                wbond*gradb(j,i)+
 643      &                wcorr*gradcorr(j,i)+
 644      &                wturn3*gcorr3_turn(j,i)+
 645      &                wturn4*gcorr4_turn(j,i)+
 646      &                wcorr5*gradcorr5(j,i)+
 647      &                wcorr6*gradcorr6(j,i)+
 648      &                wturn6*gcorr6_turn(j,i)+
 649      &                wsccor*gsccorc(j,i)
 650      &               +wscloc*gscloc(j,i)
 651 #else
 652           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 653      &                wel_loc*gel_loc(j,i)+
 654      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 655      &                welec*gelc_long(j,i)
 656      &                wel_loc*gel_loc_long(j,i)+
 657      &                wcorr*gcorr_long(j,i)+
 658      &                wcorr5*gradcorr5_long(j,i)+
 659      &                wcorr6*gradcorr6_long(j,i)+
 660      &                wturn6*gcorr6_turn_long(j,i))+
 661      &                wbond*gradb(j,i)+
 662      &                wcorr*gradcorr(j,i)+
 663      &                wturn3*gcorr3_turn(j,i)+
 664      &                wturn4*gcorr4_turn(j,i)+
 665      &                wcorr5*gradcorr5(j,i)+
 666      &                wcorr6*gradcorr6(j,i)+
 667      &                wturn6*gcorr6_turn(j,i)+
 668      &                wsccor*gsccorc(j,i)
 669      &               +wscloc*gscloc(j,i)
 670 #endif
 671           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 672      &                  wbond*gradbx(j,i)+
 673      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 674      &                  wsccor*gsccorx(j,i)
 675      &                 +wscloc*gsclocx(j,i)
 676         enddo
 677       enddo
 678 #ifdef DEBUG
 679       write (iout,*) "gloc before adding corr"
 680       do i=1,4*nres
 681         write (iout,*) i,gloc(i,icg)
 682       enddo
 683 #endif
 684       do i=1,nres-3
 685         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 686      &   +wcorr5*g_corr5_loc(i)
 687      &   +wcorr6*g_corr6_loc(i)
 688      &   +wturn4*gel_loc_turn4(i)
 689      &   +wturn3*gel_loc_turn3(i)
 690      &   +wturn6*gel_loc_turn6(i)
 691      &   +wel_loc*gel_loc_loc(i)
 692      &   +wsccor*gsccor_loc(i)
 693       enddo
 694 #ifdef DEBUG
 695       write (iout,*) "gloc after adding corr"
 696       do i=1,4*nres
 697         write (iout,*) i,gloc(i,icg)
 698       enddo
 699 #endif
 700 #ifdef MPI
 701       if (nfgtasks.gt.1) then
 702         do j=1,3
 703           do i=1,nres
 704             gradbufc(j,i)=gradc(j,i,icg)
 705             gradbufx(j,i)=gradx(j,i,icg)
 706           enddo
 707         enddo
 708         do i=1,4*nres
 709           glocbuf(i)=gloc(i,icg)
 710         enddo
 711         time00=MPI_Wtime()
 712         call MPI_Barrier(FG_COMM,IERR)
 713         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 714         time00=MPI_Wtime()
 715         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 716      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 717         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 718      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 719         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 720      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 721         time_reduce=time_reduce+MPI_Wtime()-time00
 722 #ifdef DEBUG
 723       write (iout,*) "gloc after reduce"
 724       do i=1,4*nres
 725         write (iout,*) i,gloc(i,icg)
 726       enddo
 727 #endif
 728       endif
 729 #endif
 730       if (gnorm_check) then
 731 c
 732 c Compute the maximum elements of the gradient
 733 c
 734       gvdwc_max=0.0d0
 735       gvdwc_scp_max=0.0d0
 736       gelc_max=0.0d0
 737       gvdwpp_max=0.0d0
 738       gradb_max=0.0d0
 739       ghpbc_max=0.0d0
 740       gradcorr_max=0.0d0
 741       gel_loc_max=0.0d0
 742       gcorr3_turn_max=0.0d0
 743       gcorr4_turn_max=0.0d0
 744       gradcorr5_max=0.0d0
 745       gradcorr6_max=0.0d0
 746       gcorr6_turn_max=0.0d0
 747       gsccorc_max=0.0d0
 748       gscloc_max=0.0d0
 749       gvdwx_max=0.0d0
 750       gradx_scp_max=0.0d0
 751       ghpbx_max=0.0d0
 752       gradxorr_max=0.0d0
 753       gsccorx_max=0.0d0
 754       gsclocx_max=0.0d0
 755       do i=1,nct
 756         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 757         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 758         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 759         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 760      &   gvdwc_scp_max=gvdwc_scp_norm
 761         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 762         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 763         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 764         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 765         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 766         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 767         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 768         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 769         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 770         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 771         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 772         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 773         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 774      &    gcorr3_turn(1,i)))
 775         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 776      &    gcorr3_turn_max=gcorr3_turn_norm
 777         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 778      &    gcorr4_turn(1,i)))
 779         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 780      &    gcorr4_turn_max=gcorr4_turn_norm
 781         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 782         if (gradcorr5_norm.gt.gradcorr5_max)
 783      &    gradcorr5_max=gradcorr5_norm
 784         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 785         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 786         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 787      &    gcorr6_turn(1,i)))
 788         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 789      &    gcorr6_turn_max=gcorr6_turn_norm
 790         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 791         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 792         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 793         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 794         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 795         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 796         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 797         if (gradx_scp_norm.gt.gradx_scp_max)
 798      &    gradx_scp_max=gradx_scp_norm
 799         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 800         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 801         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 802         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 803         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 804         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 805         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 806         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 807       enddo
 808       if (gradout) then
 809 #ifdef AIX
 810         open(istat,file=statname,position="append")
 811 #else
 812         open(istat,file=statname,access="append")
 813 #endif
 814         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 815      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 816      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 817      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 818      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 819      &     gsccorx_max,gsclocx_max
 820         close(istat)
 821         if (gvdwc_max.gt.1.0d4) then
 822           write (iout,*) "gvdwc gvdwx gradb gradbx"
 823           do i=nnt,nct
 824             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 825      &        gradb(j,i),gradbx(j,i),j=1,3)
 826           enddo
 827           call pdbout(0.0d0,'cipiszcze',iout)
 828           call flush(iout)
 829         endif
 830       endif
 831       endif
 832 #ifdef DEBUG
 833       write (iout,*) "gradc gradx gloc"
 834       do i=1,nres
 835         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 836      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 837       enddo
 838 #endif
 839 #ifdef TIMING
 840       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 841 #endif
 842       return
 843       end
 844 c-------------------------------------------------------------------------------
 845       subroutine rescale_weights(t_bath)
 846       implicit real*8 (a-h,o-z)
 847       include 'DIMENSIONS'
 848       include 'COMMON.IOUNITS'
 849       include 'COMMON.FFIELD'
 850       include 'COMMON.SBRIDGE'
 851       double precision kfac /2.4d0/
 852       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 853 c      facT=temp0/t_bath
 854 c      facT=2*temp0/(t_bath+temp0)
 855       if (rescale_mode.eq.0) then
 856         facT=1.0d0
 857         facT2=1.0d0
 858         facT3=1.0d0
 859         facT4=1.0d0
 860         facT5=1.0d0
 861       else if (rescale_mode.eq.1) then
 862         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 863         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 864         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 865         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 866         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 867       else if (rescale_mode.eq.2) then
 868         x=t_bath/temp0
 869         x2=x*x
 870         x3=x2*x
 871         x4=x3*x
 872         x5=x4*x
 873         facT=licznik/dlog(dexp(x)+dexp(-x))
 874         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 875         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 876         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 877         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 878       else
 879         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 880         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 881 #ifdef MPI
 882        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 883 #endif
 884        stop 555
 885       endif
 886       welec=weights(3)*fact
 887       wcorr=weights(4)*fact3
 888       wcorr5=weights(5)*fact4
 889       wcorr6=weights(6)*fact5
 890       wel_loc=weights(7)*fact2
 891       wturn3=weights(8)*fact2
 892       wturn4=weights(9)*fact3
 893       wturn6=weights(10)*fact5
 894       wtor=weights(13)*fact
 895       wtor_d=weights(14)*fact2
 896       wsccor=weights(21)*fact
 897
 898       return
 899       end
 900 C------------------------------------------------------------------------
 901       subroutine enerprint(energia)
 902       implicit real*8 (a-h,o-z)
 903       include 'DIMENSIONS'
 904       include 'COMMON.IOUNITS'
 905       include 'COMMON.FFIELD'
 906       include 'COMMON.SBRIDGE'
 907       include 'COMMON.MD'
 908       double precision energia(0:n_ene)
 909       etot=energia(0)
 910       evdw=energia(1)
 911       evdw2=energia(2)
 912 #ifdef SCP14
 913       evdw2=energia(2)+energia(18)
 914 #else
 915       evdw2=energia(2)
 916 #endif
 917       ees=energia(3)
 918 #ifdef SPLITELE
 919       evdw1=energia(16)
 920 #endif
 921       ecorr=energia(4)
 922       ecorr5=energia(5)
 923       ecorr6=energia(6)
 924       eel_loc=energia(7)
 925       eello_turn3=energia(8)
 926       eello_turn4=energia(9)
 927       eello_turn6=energia(10)
 928       ebe=energia(11)
 929       escloc=energia(12)
 930       etors=energia(13)
 931       etors_d=energia(14)
 932       ehpb=energia(15)
 933       edihcnstr=energia(19)
 934       estr=energia(17)
 935       Uconst=energia(20)
 936       esccor=energia(21)
 937 #ifdef SPLITELE
 938       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 939      &  estr,wbond,ebe,wang,
 940      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 941      &  ecorr,wcorr,
 942      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 943      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 944      &  edihcnstr,ebr*nss,
 945      &  Uconst,etot
 946    10 format (/'Virtual-chain energies:'//
 947      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 948      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 949      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 950      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 951      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 952      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 953      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 954      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 955      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 956      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 957      & ' (SS bridges & dist. cnstr.)'/
 958      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 959      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 960      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 961      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 962      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 963      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 964      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 965      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 966      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 967      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 968      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 969      & 'ETOT=  ',1pE16.6,' (total)')
 970 #else
 971       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 972      &  estr,wbond,ebe,wang,
 973      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 974      &  ecorr,wcorr,
 975      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 976      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 977      &  ebr*nss,Uconst,etot
 978    10 format (/'Virtual-chain energies:'//
 979      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 980      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 981      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 982      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 983      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 984      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 985      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 986      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 987      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 988      & ' (SS bridges & dist. cnstr.)'/
 989      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 990      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 992      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 993      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 994      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 995      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 996      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 997      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 998      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 999      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1000      & 'ETOT=  ',1pE16.6,' (total)')
1001 #endif
1002       return
1003       end
1004 C-----------------------------------------------------------------------
1005       subroutine elj(evdw)
1006 C
1007 C This subroutine calculates the interaction energy of nonbonded side chains
1008 C assuming the LJ potential of interaction.
1009 C
1010       implicit real*8 (a-h,o-z)
1011       include 'DIMENSIONS'
1012       parameter (accur=1.0d-10)
1013       include 'COMMON.GEO'
1014       include 'COMMON.VAR'
1015       include 'COMMON.LOCAL'
1016       include 'COMMON.CHAIN'
1017       include 'COMMON.DERIV'
1018       include 'COMMON.INTERACT'
1019       include 'COMMON.TORSION'
1020       include 'COMMON.SBRIDGE'
1021       include 'COMMON.NAMES'
1022       include 'COMMON.IOUNITS'
1023       include 'COMMON.CONTACTS'
1024       dimension gg(3)
1025 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1026       evdw=0.0D0
1027       do i=iatsc_s,iatsc_e
1028         itypi=itype(i)
1029         if (itypi.eq.21) cycle
1030         itypi1=itype(i+1)
1031         xi=c(1,nres+i)
1032         yi=c(2,nres+i)
1033         zi=c(3,nres+i)
1034 C Change 12/1/95
1035         num_conti=0
1036 C
1037 C Calculate SC interaction energy.
1038 C
1039         do iint=1,nint_gr(i)
1040 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1041 cd   &                  'iend=',iend(i,iint)
1042           do j=istart(i,iint),iend(i,iint)
1043             itypj=itype(j)
1044             if (itypj.eq.21) cycle
1045             xj=c(1,nres+j)-xi
1046             yj=c(2,nres+j)-yi
1047             zj=c(3,nres+j)-zi
1048 C Change 12/1/95 to calculate four-body interactions
1049             rij=xj*xj+yj*yj+zj*zj
1050             rrij=1.0D0/rij
1051 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1052             eps0ij=eps(itypi,itypj)
1053             fac=rrij**expon2
1054             e1=fac*fac*aa(itypi,itypj)
1055             e2=fac*bb(itypi,itypj)
1056             evdwij=e1+e2
1057 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1058 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1059 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1060 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1061 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1062 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1063             evdw=evdw+evdwij
1064 C
1065 C Calculate the components of the gradient in DC and X
1066 C
1067             fac=-rrij*(e1+evdwij)
1068             gg(1)=xj*fac
1069             gg(2)=yj*fac
1070             gg(3)=zj*fac
1071             do k=1,3
1072               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1073               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1074               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1075               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1076             enddo
1077 cgrad            do k=i,j-1
1078 cgrad              do l=1,3
1079 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1080 cgrad              enddo
1081 cgrad            enddo
1082 C
1083 C 12/1/95, revised on 5/20/97
1084 C
1085 C Calculate the contact function. The ith column of the array JCONT will
1086 C contain the numbers of atoms that make contacts with the atom I (of numbers
1087 C greater than I). The arrays FACONT and GACONT will contain the values of
1088 C the contact function and its derivative.
1089 C
1090 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1091 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1092 C Uncomment next line, if the correlation interactions are contact function only
1093             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1094               rij=dsqrt(rij)
1095               sigij=sigma(itypi,itypj)
1096               r0ij=rs0(itypi,itypj)
1097 C
1098 C Check whether the SC's are not too far to make a contact.
1099 C
1100               rcut=1.5d0*r0ij
1101               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1102 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1103 C
1104               if (fcont.gt.0.0D0) then
1105 C If the SC-SC distance if close to sigma, apply spline.
1106 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1107 cAdam &             fcont1,fprimcont1)
1108 cAdam           fcont1=1.0d0-fcont1
1109 cAdam           if (fcont1.gt.0.0d0) then
1110 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1111 cAdam             fcont=fcont*fcont1
1112 cAdam           endif
1113 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1114 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1115 cga             do k=1,3
1116 cga               gg(k)=gg(k)*eps0ij
1117 cga             enddo
1118 cga             eps0ij=-evdwij*eps0ij
1119 C Uncomment for AL's type of SC correlation interactions.
1120 cadam           eps0ij=-evdwij
1121                 num_conti=num_conti+1
1122                 jcont(num_conti,i)=j
1123                 facont(num_conti,i)=fcont*eps0ij
1124                 fprimcont=eps0ij*fprimcont/rij
1125                 fcont=expon*fcont
1126 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1127 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1128 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1129 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1130                 gacont(1,num_conti,i)=-fprimcont*xj
1131                 gacont(2,num_conti,i)=-fprimcont*yj
1132                 gacont(3,num_conti,i)=-fprimcont*zj
1133 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1134 cd              write (iout,'(2i3,3f10.5)')
1135 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1136               endif
1137             endif
1138           enddo      ! j
1139         enddo        ! iint
1140 C Change 12/1/95
1141         num_cont(i)=num_conti
1142       enddo          ! i
1143       do i=1,nct
1144         do j=1,3
1145           gvdwc(j,i)=expon*gvdwc(j,i)
1146           gvdwx(j,i)=expon*gvdwx(j,i)
1147         enddo
1148       enddo
1149 C******************************************************************************
1150 C
1151 C                              N O T E !!!
1152 C
1153 C To save time, the factor of EXPON has been extracted from ALL components
1154 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1155 C use!
1156 C
1157 C******************************************************************************
1158       return
1159       end
1160 C-----------------------------------------------------------------------------
1161       subroutine eljk(evdw)
1162 C
1163 C This subroutine calculates the interaction energy of nonbonded side chains
1164 C assuming the LJK potential of interaction.
1165 C
1166       implicit real*8 (a-h,o-z)
1167       include 'DIMENSIONS'
1168       include 'COMMON.GEO'
1169       include 'COMMON.VAR'
1170       include 'COMMON.LOCAL'
1171       include 'COMMON.CHAIN'
1172       include 'COMMON.DERIV'
1173       include 'COMMON.INTERACT'
1174       include 'COMMON.IOUNITS'
1175       include 'COMMON.NAMES'
1176       dimension gg(3)
1177       logical scheck
1178 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1179       evdw=0.0D0
1180       do i=iatsc_s,iatsc_e
1181         itypi=itype(i)
1182         if (itypi.eq.21) cycle
1183         itypi1=itype(i+1)
1184         xi=c(1,nres+i)
1185         yi=c(2,nres+i)
1186         zi=c(3,nres+i)
1187 C
1188 C Calculate SC interaction energy.
1189 C
1190         do iint=1,nint_gr(i)
1191           do j=istart(i,iint),iend(i,iint)
1192             itypj=itype(j)
1193             if (itypj.eq.21) cycle
1194             xj=c(1,nres+j)-xi
1195             yj=c(2,nres+j)-yi
1196             zj=c(3,nres+j)-zi
1197             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1198             fac_augm=rrij**expon
1199             e_augm=augm(itypi,itypj)*fac_augm
1200             r_inv_ij=dsqrt(rrij)
1201             rij=1.0D0/r_inv_ij
1202             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1203             fac=r_shift_inv**expon
1204             e1=fac*fac*aa(itypi,itypj)
1205             e2=fac*bb(itypi,itypj)
1206             evdwij=e_augm+e1+e2
1207 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1208 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1209 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1210 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1211 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1212 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1213 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1214             evdw=evdw+evdwij
1215 C
1216 C Calculate the components of the gradient in DC and X
1217 C
1218             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1219             gg(1)=xj*fac
1220             gg(2)=yj*fac
1221             gg(3)=zj*fac
1222             do k=1,3
1223               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1224               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1225               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1226               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1227             enddo
1228 cgrad            do k=i,j-1
1229 cgrad              do l=1,3
1230 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1231 cgrad              enddo
1232 cgrad            enddo
1233           enddo      ! j
1234         enddo        ! iint
1235       enddo          ! i
1236       do i=1,nct
1237         do j=1,3
1238           gvdwc(j,i)=expon*gvdwc(j,i)
1239           gvdwx(j,i)=expon*gvdwx(j,i)
1240         enddo
1241       enddo
1242       return
1243       end
1244 C-----------------------------------------------------------------------------
1245       subroutine ebp(evdw)
1246 C
1247 C This subroutine calculates the interaction energy of nonbonded side chains
1248 C assuming the Berne-Pechukas potential of interaction.
1249 C
1250       implicit real*8 (a-h,o-z)
1251       include 'DIMENSIONS'
1252       include 'COMMON.GEO'
1253       include 'COMMON.VAR'
1254       include 'COMMON.LOCAL'
1255       include 'COMMON.CHAIN'
1256       include 'COMMON.DERIV'
1257       include 'COMMON.NAMES'
1258       include 'COMMON.INTERACT'
1259       include 'COMMON.IOUNITS'
1260       include 'COMMON.CALC'
1261       common /srutu/ icall
1262 c     double precision rrsave(maxdim)
1263       logical lprn
1264       evdw=0.0D0
1265 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1266       evdw=0.0D0
1267 c     if (icall.eq.0) then
1268 c       lprn=.true.
1269 c     else
1270         lprn=.false.
1271 c     endif
1272       ind=0
1273       do i=iatsc_s,iatsc_e
1274         itypi=itype(i)
1275         if (itypi.eq.21) cycle
1276         itypi1=itype(i+1)
1277         xi=c(1,nres+i)
1278         yi=c(2,nres+i)
1279         zi=c(3,nres+i)
1280         dxi=dc_norm(1,nres+i)
1281         dyi=dc_norm(2,nres+i)
1282         dzi=dc_norm(3,nres+i)
1283 c        dsci_inv=dsc_inv(itypi)
1284         dsci_inv=vbld_inv(i+nres)
1285 C
1286 C Calculate SC interaction energy.
1287 C
1288         do iint=1,nint_gr(i)
1289           do j=istart(i,iint),iend(i,iint)
1290             ind=ind+1
1291             itypj=itype(j)
1292             if (itypj.eq.21) cycle
1293 c            dscj_inv=dsc_inv(itypj)
1294             dscj_inv=vbld_inv(j+nres)
1295             chi1=chi(itypi,itypj)
1296             chi2=chi(itypj,itypi)
1297             chi12=chi1*chi2
1298             chip1=chip(itypi)
1299             chip2=chip(itypj)
1300             chip12=chip1*chip2
1301             alf1=alp(itypi)
1302             alf2=alp(itypj)
1303             alf12=0.5D0*(alf1+alf2)
1304 C For diagnostics only!!!
1305 c           chi1=0.0D0
1306 c           chi2=0.0D0
1307 c           chi12=0.0D0
1308 c           chip1=0.0D0
1309 c           chip2=0.0D0
1310 c           chip12=0.0D0
1311 c           alf1=0.0D0
1312 c           alf2=0.0D0
1313 c           alf12=0.0D0
1314             xj=c(1,nres+j)-xi
1315             yj=c(2,nres+j)-yi
1316             zj=c(3,nres+j)-zi
1317             dxj=dc_norm(1,nres+j)
1318             dyj=dc_norm(2,nres+j)
1319             dzj=dc_norm(3,nres+j)
1320             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1321 cd          if (icall.eq.0) then
1322 cd            rrsave(ind)=rrij
1323 cd          else
1324 cd            rrij=rrsave(ind)
1325 cd          endif
1326             rij=dsqrt(rrij)
1327 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1328             call sc_angular
1329 C Calculate whole angle-dependent part of epsilon and contributions
1330 C to its derivatives
1331             fac=(rrij*sigsq)**expon2
1332             e1=fac*fac*aa(itypi,itypj)
1333             e2=fac*bb(itypi,itypj)
1334             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1335             eps2der=evdwij*eps3rt
1336             eps3der=evdwij*eps2rt
1337             evdwij=evdwij*eps2rt*eps3rt
1338             evdw=evdw+evdwij
1339             if (lprn) then
1340             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1341             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1342 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1343 cd     &        restyp(itypi),i,restyp(itypj),j,
1344 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1345 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1346 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1347 cd     &        evdwij
1348             endif
1349 C Calculate gradient components.
1350             e1=e1*eps1*eps2rt**2*eps3rt**2
1351             fac=-expon*(e1+evdwij)
1352             sigder=fac/sigsq
1353             fac=rrij*fac
1354 C Calculate radial part of the gradient
1355             gg(1)=xj*fac
1356             gg(2)=yj*fac
1357             gg(3)=zj*fac
1358 C Calculate the angular part of the gradient and sum add the contributions
1359 C to the appropriate components of the Cartesian gradient.
1360             call sc_grad
1361           enddo      ! j
1362         enddo        ! iint
1363       enddo          ! i
1364 c     stop
1365       return
1366       end
1367 C-----------------------------------------------------------------------------
1368       subroutine egb(evdw)
1369 C
1370 C This subroutine calculates the interaction energy of nonbonded side chains
1371 C assuming the Gay-Berne potential of interaction.
1372 C
1373       implicit real*8 (a-h,o-z)
1374       include 'DIMENSIONS'
1375       include 'COMMON.GEO'
1376       include 'COMMON.VAR'
1377       include 'COMMON.LOCAL'
1378       include 'COMMON.CHAIN'
1379       include 'COMMON.DERIV'
1380       include 'COMMON.NAMES'
1381       include 'COMMON.INTERACT'
1382       include 'COMMON.IOUNITS'
1383       include 'COMMON.CALC'
1384       include 'COMMON.CONTROL'
1385       logical lprn
1386       evdw=0.0D0
1387 ccccc      energy_dec=.false.
1388 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1389       evdw=0.0D0
1390       lprn=.false.
1391 c     if (icall.eq.0) lprn=.false.
1392       ind=0
1393       do i=iatsc_s,iatsc_e
1394         itypi=itype(i)
1395         if (itypi.eq.21) cycle
1396         itypi1=itype(i+1)
1397         xi=c(1,nres+i)
1398         yi=c(2,nres+i)
1399         zi=c(3,nres+i)
1400         dxi=dc_norm(1,nres+i)
1401         dyi=dc_norm(2,nres+i)
1402         dzi=dc_norm(3,nres+i)
1403 c        dsci_inv=dsc_inv(itypi)
1404         dsci_inv=vbld_inv(i+nres)
1405 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1406 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1407 C
1408 C Calculate SC interaction energy.
1409 C
1410         do iint=1,nint_gr(i)
1411           do j=istart(i,iint),iend(i,iint)
1412             ind=ind+1
1413             itypj=itype(j)
1414             if (itypj.eq.21) cycle
1415 c            dscj_inv=dsc_inv(itypj)
1416             dscj_inv=vbld_inv(j+nres)
1417 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1418 c     &       1.0d0/vbld(j+nres)
1419 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1420             sig0ij=sigma(itypi,itypj)
1421             chi1=chi(itypi,itypj)
1422             chi2=chi(itypj,itypi)
1423             chi12=chi1*chi2
1424             chip1=chip(itypi)
1425             chip2=chip(itypj)
1426             chip12=chip1*chip2
1427             alf1=alp(itypi)
1428             alf2=alp(itypj)
1429             alf12=0.5D0*(alf1+alf2)
1430 C For diagnostics only!!!
1431 c           chi1=0.0D0
1432 c           chi2=0.0D0
1433 c           chi12=0.0D0
1434 c           chip1=0.0D0
1435 c           chip2=0.0D0
1436 c           chip12=0.0D0
1437 c           alf1=0.0D0
1438 c           alf2=0.0D0
1439 c           alf12=0.0D0
1440             xj=c(1,nres+j)-xi
1441             yj=c(2,nres+j)-yi
1442             zj=c(3,nres+j)-zi
1443             dxj=dc_norm(1,nres+j)
1444             dyj=dc_norm(2,nres+j)
1445             dzj=dc_norm(3,nres+j)
1446 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1447 c            write (iout,*) "j",j," dc_norm",
1448 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1449             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1450             rij=dsqrt(rrij)
1451 C Calculate angle-dependent terms of energy and contributions to their
1452 C derivatives.
1453             call sc_angular
1454             sigsq=1.0D0/sigsq
1455             sig=sig0ij*dsqrt(sigsq)
1456             rij_shift=1.0D0/rij-sig+sig0ij
1457 c for diagnostics; uncomment
1458 c            rij_shift=1.2*sig0ij
1459 C I hate to put IF's in the loops, but here don't have another choice!!!!
1460             if (rij_shift.le.0.0D0) then
1461               evdw=1.0D20
1462 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1463 cd     &        restyp(itypi),i,restyp(itypj),j,
1464 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1465               return
1466             endif
1467             sigder=-sig*sigsq
1468 c---------------------------------------------------------------
1469             rij_shift=1.0D0/rij_shift
1470             fac=rij_shift**expon
1471             e1=fac*fac*aa(itypi,itypj)
1472             e2=fac*bb(itypi,itypj)
1473             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1474             eps2der=evdwij*eps3rt
1475             eps3der=evdwij*eps2rt
1476 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1477 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1478             evdwij=evdwij*eps2rt*eps3rt
1479             evdw=evdw+evdwij
1480             if (lprn) then
1481             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1482             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1483             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1484      &        restyp(itypi),i,restyp(itypj),j,
1485      &        epsi,sigm,chi1,chi2,chip1,chip2,
1486      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1487      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1488      &        evdwij
1489             endif
1490
1491             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1492      &                        'evdw',i,j,evdwij
1493
1494 C Calculate gradient components.
1495             e1=e1*eps1*eps2rt**2*eps3rt**2
1496             fac=-expon*(e1+evdwij)*rij_shift
1497             sigder=fac*sigder
1498             fac=rij*fac
1499 c            fac=0.0d0
1500 C Calculate the radial part of the gradient
1501             gg(1)=xj*fac
1502             gg(2)=yj*fac
1503             gg(3)=zj*fac
1504 C Calculate angular part of the gradient.
1505             call sc_grad
1506           enddo      ! j
1507         enddo        ! iint
1508       enddo          ! i
1509 c      write (iout,*) "Number of loop steps in EGB:",ind
1510 cccc      energy_dec=.false.
1511       return
1512       end
1513 C-----------------------------------------------------------------------------
1514       subroutine egbv(evdw)
1515 C
1516 C This subroutine calculates the interaction energy of nonbonded side chains
1517 C assuming the Gay-Berne-Vorobjev potential of interaction.
1518 C
1519       implicit real*8 (a-h,o-z)
1520       include 'DIMENSIONS'
1521       include 'COMMON.GEO'
1522       include 'COMMON.VAR'
1523       include 'COMMON.LOCAL'
1524       include 'COMMON.CHAIN'
1525       include 'COMMON.DERIV'
1526       include 'COMMON.NAMES'
1527       include 'COMMON.INTERACT'
1528       include 'COMMON.IOUNITS'
1529       include 'COMMON.CALC'
1530       common /srutu/ icall
1531       logical lprn
1532       evdw=0.0D0
1533 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1534       evdw=0.0D0
1535       lprn=.false.
1536 c     if (icall.eq.0) lprn=.true.
1537       ind=0
1538       do i=iatsc_s,iatsc_e
1539         itypi=itype(i)
1540         if (itypi.eq.21) cycle
1541         itypi1=itype(i+1)
1542         xi=c(1,nres+i)
1543         yi=c(2,nres+i)
1544         zi=c(3,nres+i)
1545         dxi=dc_norm(1,nres+i)
1546         dyi=dc_norm(2,nres+i)
1547         dzi=dc_norm(3,nres+i)
1548 c        dsci_inv=dsc_inv(itypi)
1549         dsci_inv=vbld_inv(i+nres)
1550 C
1551 C Calculate SC interaction energy.
1552 C
1553         do iint=1,nint_gr(i)
1554           do j=istart(i,iint),iend(i,iint)
1555             ind=ind+1
1556             itypj=itype(j)
1557             if (itypj.eq.21) cycle
1558 c            dscj_inv=dsc_inv(itypj)
1559             dscj_inv=vbld_inv(j+nres)
1560             sig0ij=sigma(itypi,itypj)
1561             r0ij=r0(itypi,itypj)
1562             chi1=chi(itypi,itypj)
1563             chi2=chi(itypj,itypi)
1564             chi12=chi1*chi2
1565             chip1=chip(itypi)
1566             chip2=chip(itypj)
1567             chip12=chip1*chip2
1568             alf1=alp(itypi)
1569             alf2=alp(itypj)
1570             alf12=0.5D0*(alf1+alf2)
1571 C For diagnostics only!!!
1572 c           chi1=0.0D0
1573 c           chi2=0.0D0
1574 c           chi12=0.0D0
1575 c           chip1=0.0D0
1576 c           chip2=0.0D0
1577 c           chip12=0.0D0
1578 c           alf1=0.0D0
1579 c           alf2=0.0D0
1580 c           alf12=0.0D0
1581             xj=c(1,nres+j)-xi
1582             yj=c(2,nres+j)-yi
1583             zj=c(3,nres+j)-zi
1584             dxj=dc_norm(1,nres+j)
1585             dyj=dc_norm(2,nres+j)
1586             dzj=dc_norm(3,nres+j)
1587             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1588             rij=dsqrt(rrij)
1589 C Calculate angle-dependent terms of energy and contributions to their
1590 C derivatives.
1591             call sc_angular
1592             sigsq=1.0D0/sigsq
1593             sig=sig0ij*dsqrt(sigsq)
1594             rij_shift=1.0D0/rij-sig+r0ij
1595 C I hate to put IF's in the loops, but here don't have another choice!!!!
1596             if (rij_shift.le.0.0D0) then
1597               evdw=1.0D20
1598               return
1599             endif
1600             sigder=-sig*sigsq
1601 c---------------------------------------------------------------
1602             rij_shift=1.0D0/rij_shift
1603             fac=rij_shift**expon
1604             e1=fac*fac*aa(itypi,itypj)
1605             e2=fac*bb(itypi,itypj)
1606             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1607             eps2der=evdwij*eps3rt
1608             eps3der=evdwij*eps2rt
1609             fac_augm=rrij**expon
1610             e_augm=augm(itypi,itypj)*fac_augm
1611             evdwij=evdwij*eps2rt*eps3rt
1612             evdw=evdw+evdwij+e_augm
1613             if (lprn) then
1614             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1615             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1616             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1617      &        restyp(itypi),i,restyp(itypj),j,
1618      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1619      &        chi1,chi2,chip1,chip2,
1620      &        eps1,eps2rt**2,eps3rt**2,
1621      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1622      &        evdwij+e_augm
1623             endif
1624 C Calculate gradient components.
1625             e1=e1*eps1*eps2rt**2*eps3rt**2
1626             fac=-expon*(e1+evdwij)*rij_shift
1627             sigder=fac*sigder
1628             fac=rij*fac-2*expon*rrij*e_augm
1629 C Calculate the radial part of the gradient
1630             gg(1)=xj*fac
1631             gg(2)=yj*fac
1632             gg(3)=zj*fac
1633 C Calculate angular part of the gradient.
1634             call sc_grad
1635           enddo      ! j
1636         enddo        ! iint
1637       enddo          ! i
1638       end
1639 C-----------------------------------------------------------------------------
1640       subroutine sc_angular
1641 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1642 C om12. Called by ebp, egb, and egbv.
1643       implicit none
1644       include 'COMMON.CALC'
1645       include 'COMMON.IOUNITS'
1646       erij(1)=xj*rij
1647       erij(2)=yj*rij
1648       erij(3)=zj*rij
1649       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1650       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1651       om12=dxi*dxj+dyi*dyj+dzi*dzj
1652       chiom12=chi12*om12
1653 C Calculate eps1(om12) and its derivative in om12
1654       faceps1=1.0D0-om12*chiom12
1655       faceps1_inv=1.0D0/faceps1
1656       eps1=dsqrt(faceps1_inv)
1657 C Following variable is eps1*deps1/dom12
1658       eps1_om12=faceps1_inv*chiom12
1659 c diagnostics only
1660 c      faceps1_inv=om12
1661 c      eps1=om12
1662 c      eps1_om12=1.0d0
1663 c      write (iout,*) "om12",om12," eps1",eps1
1664 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1665 C and om12.
1666       om1om2=om1*om2
1667       chiom1=chi1*om1
1668       chiom2=chi2*om2
1669       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1670       sigsq=1.0D0-facsig*faceps1_inv
1671       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1672       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1673       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1674 c diagnostics only
1675 c      sigsq=1.0d0
1676 c      sigsq_om1=0.0d0
1677 c      sigsq_om2=0.0d0
1678 c      sigsq_om12=0.0d0
1679 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1680 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1681 c     &    " eps1",eps1
1682 C Calculate eps2 and its derivatives in om1, om2, and om12.
1683       chipom1=chip1*om1
1684       chipom2=chip2*om2
1685       chipom12=chip12*om12
1686       facp=1.0D0-om12*chipom12
1687       facp_inv=1.0D0/facp
1688       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1689 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1690 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1691 C Following variable is the square root of eps2
1692       eps2rt=1.0D0-facp1*facp_inv
1693 C Following three variables are the derivatives of the square root of eps
1694 C in om1, om2, and om12.
1695       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1696       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1697       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1698 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1699       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1700 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1701 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1702 c     &  " eps2rt_om12",eps2rt_om12
1703 C Calculate whole angle-dependent part of epsilon and contributions
1704 C to its derivatives
1705       return
1706       end
1707 C----------------------------------------------------------------------------
1708       subroutine sc_grad
1709       implicit real*8 (a-h,o-z)
1710       include 'DIMENSIONS'
1711       include 'COMMON.CHAIN'
1712       include 'COMMON.DERIV'
1713       include 'COMMON.CALC'
1714       include 'COMMON.IOUNITS'
1715       double precision dcosom1(3),dcosom2(3)
1716       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1717       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1718       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1719      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1720 c diagnostics only
1721 c      eom1=0.0d0
1722 c      eom2=0.0d0
1723 c      eom12=evdwij*eps1_om12
1724 c end diagnostics
1725 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1726 c     &  " sigder",sigder
1727 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1728 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1729       do k=1,3
1730         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1731         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1732       enddo
1733       do k=1,3
1734         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1735       enddo
1736 c      write (iout,*) "gg",(gg(k),k=1,3)
1737       do k=1,3
1738         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1739      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1740      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1741         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1742      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1743      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1744 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1745 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1746 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1747 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1748       enddo
1749 C
1750 C Calculate the components of the gradient in DC and X
1751 C
1752 cgrad      do k=i,j-1
1753 cgrad        do l=1,3
1754 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1755 cgrad        enddo
1756 cgrad      enddo
1757       do l=1,3
1758         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1759         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1760       enddo
1761       return
1762       end
1763 C-----------------------------------------------------------------------
1764       subroutine e_softsphere(evdw)
1765 C
1766 C This subroutine calculates the interaction energy of nonbonded side chains
1767 C assuming the LJ potential of interaction.
1768 C
1769       implicit real*8 (a-h,o-z)
1770       include 'DIMENSIONS'
1771       parameter (accur=1.0d-10)
1772       include 'COMMON.GEO'
1773       include 'COMMON.VAR'
1774       include 'COMMON.LOCAL'
1775       include 'COMMON.CHAIN'
1776       include 'COMMON.DERIV'
1777       include 'COMMON.INTERACT'
1778       include 'COMMON.TORSION'
1779       include 'COMMON.SBRIDGE'
1780       include 'COMMON.NAMES'
1781       include 'COMMON.IOUNITS'
1782       include 'COMMON.CONTACTS'
1783       dimension gg(3)
1784 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1785       evdw=0.0D0
1786       do i=iatsc_s,iatsc_e
1787         itypi=itype(i)
1788         if (itypi.eq.21) cycle
1789         itypi1=itype(i+1)
1790         xi=c(1,nres+i)
1791         yi=c(2,nres+i)
1792         zi=c(3,nres+i)
1793 C
1794 C Calculate SC interaction energy.
1795 C
1796         do iint=1,nint_gr(i)
1797 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1798 cd   &                  'iend=',iend(i,iint)
1799           do j=istart(i,iint),iend(i,iint)
1800             itypj=itype(j)
1801             if (itypj.eq.21) cycle
1802             xj=c(1,nres+j)-xi
1803             yj=c(2,nres+j)-yi
1804             zj=c(3,nres+j)-zi
1805             rij=xj*xj+yj*yj+zj*zj
1806 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1807             r0ij=r0(itypi,itypj)
1808             r0ijsq=r0ij*r0ij
1809 c            print *,i,j,r0ij,dsqrt(rij)
1810             if (rij.lt.r0ijsq) then
1811               evdwij=0.25d0*(rij-r0ijsq)**2
1812               fac=rij-r0ijsq
1813             else
1814               evdwij=0.0d0
1815               fac=0.0d0
1816             endif
1817             evdw=evdw+evdwij
1818 C
1819 C Calculate the components of the gradient in DC and X
1820 C
1821             gg(1)=xj*fac
1822             gg(2)=yj*fac
1823             gg(3)=zj*fac
1824             do k=1,3
1825               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1826               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1827               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1828               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1829             enddo
1830 cgrad            do k=i,j-1
1831 cgrad              do l=1,3
1832 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1833 cgrad              enddo
1834 cgrad            enddo
1835           enddo ! j
1836         enddo ! iint
1837       enddo ! i
1838       return
1839       end
1840 C--------------------------------------------------------------------------
1841       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1842      &              eello_turn4)
1843 C
1844 C Soft-sphere potential of p-p interaction
1845 C
1846       implicit real*8 (a-h,o-z)
1847       include 'DIMENSIONS'
1848       include 'COMMON.CONTROL'
1849       include 'COMMON.IOUNITS'
1850       include 'COMMON.GEO'
1851       include 'COMMON.VAR'
1852       include 'COMMON.LOCAL'
1853       include 'COMMON.CHAIN'
1854       include 'COMMON.DERIV'
1855       include 'COMMON.INTERACT'
1856       include 'COMMON.CONTACTS'
1857       include 'COMMON.TORSION'
1858       include 'COMMON.VECTORS'
1859       include 'COMMON.FFIELD'
1860       dimension ggg(3)
1861 cd      write(iout,*) 'In EELEC_soft_sphere'
1862       ees=0.0D0
1863       evdw1=0.0D0
1864       eel_loc=0.0d0
1865       eello_turn3=0.0d0
1866       eello_turn4=0.0d0
1867       ind=0
1868       do i=iatel_s,iatel_e
1869         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
1870         dxi=dc(1,i)
1871         dyi=dc(2,i)
1872         dzi=dc(3,i)
1873         xmedi=c(1,i)+0.5d0*dxi
1874         ymedi=c(2,i)+0.5d0*dyi
1875         zmedi=c(3,i)+0.5d0*dzi
1876         num_conti=0
1877 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1878         do j=ielstart(i),ielend(i)
1879           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
1880           ind=ind+1
1881           iteli=itel(i)
1882           itelj=itel(j)
1883           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1884           r0ij=rpp(iteli,itelj)
1885           r0ijsq=r0ij*r0ij
1886           dxj=dc(1,j)
1887           dyj=dc(2,j)
1888           dzj=dc(3,j)
1889           xj=c(1,j)+0.5D0*dxj-xmedi
1890           yj=c(2,j)+0.5D0*dyj-ymedi
1891           zj=c(3,j)+0.5D0*dzj-zmedi
1892           rij=xj*xj+yj*yj+zj*zj
1893           if (rij.lt.r0ijsq) then
1894             evdw1ij=0.25d0*(rij-r0ijsq)**2
1895             fac=rij-r0ijsq
1896           else
1897             evdw1ij=0.0d0
1898             fac=0.0d0
1899           endif
1900           evdw1=evdw1+evdw1ij
1901 C
1902 C Calculate contributions to the Cartesian gradient.
1903 C
1904           ggg(1)=fac*xj
1905           ggg(2)=fac*yj
1906           ggg(3)=fac*zj
1907           do k=1,3
1908             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1909             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1910           enddo
1911 *
1912 * Loop over residues i+1 thru j-1.
1913 *
1914 cgrad          do k=i+1,j-1
1915 cgrad            do l=1,3
1916 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1917 cgrad            enddo
1918 cgrad          enddo
1919         enddo ! j
1920       enddo   ! i
1921 cgrad      do i=nnt,nct-1
1922 cgrad        do k=1,3
1923 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1924 cgrad        enddo
1925 cgrad        do j=i+1,nct-1
1926 cgrad          do k=1,3
1927 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1928 cgrad          enddo
1929 cgrad        enddo
1930 cgrad      enddo
1931       return
1932       end
1933 c------------------------------------------------------------------------------
1934       subroutine vec_and_deriv
1935       implicit real*8 (a-h,o-z)
1936       include 'DIMENSIONS'
1937 #ifdef MPI
1938       include 'mpif.h'
1939 #endif
1940       include 'COMMON.IOUNITS'
1941       include 'COMMON.GEO'
1942       include 'COMMON.VAR'
1943       include 'COMMON.LOCAL'
1944       include 'COMMON.CHAIN'
1945       include 'COMMON.VECTORS'
1946       include 'COMMON.SETUP'
1947       include 'COMMON.TIME1'
1948       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1949 C Compute the local reference systems. For reference system (i), the
1950 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1951 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1952 #ifdef PARVEC
1953       do i=ivec_start,ivec_end
1954 #else
1955       do i=1,nres-1
1956 #endif
1957           if (i.eq.nres-1) then
1958 C Case of the last full residue
1959 C Compute the Z-axis
1960             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1961             costh=dcos(pi-theta(nres))
1962             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1963             do k=1,3
1964               uz(k,i)=fac*uz(k,i)
1965             enddo
1966 C Compute the derivatives of uz
1967             uzder(1,1,1)= 0.0d0
1968             uzder(2,1,1)=-dc_norm(3,i-1)
1969             uzder(3,1,1)= dc_norm(2,i-1)
1970             uzder(1,2,1)= dc_norm(3,i-1)
1971             uzder(2,2,1)= 0.0d0
1972             uzder(3,2,1)=-dc_norm(1,i-1)
1973             uzder(1,3,1)=-dc_norm(2,i-1)
1974             uzder(2,3,1)= dc_norm(1,i-1)
1975             uzder(3,3,1)= 0.0d0
1976             uzder(1,1,2)= 0.0d0
1977             uzder(2,1,2)= dc_norm(3,i)
1978             uzder(3,1,2)=-dc_norm(2,i)
1979             uzder(1,2,2)=-dc_norm(3,i)
1980             uzder(2,2,2)= 0.0d0
1981             uzder(3,2,2)= dc_norm(1,i)
1982             uzder(1,3,2)= dc_norm(2,i)
1983             uzder(2,3,2)=-dc_norm(1,i)
1984             uzder(3,3,2)= 0.0d0
1985 C Compute the Y-axis
1986             facy=fac
1987             do k=1,3
1988               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1989             enddo
1990 C Compute the derivatives of uy
1991             do j=1,3
1992               do k=1,3
1993                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1994      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1995                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1996               enddo
1997               uyder(j,j,1)=uyder(j,j,1)-costh
1998               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1999             enddo
2000             do j=1,2
2001               do k=1,3
2002                 do l=1,3
2003                   uygrad(l,k,j,i)=uyder(l,k,j)
2004                   uzgrad(l,k,j,i)=uzder(l,k,j)
2005                 enddo
2006               enddo
2007             enddo
2008             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2009             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2010             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2011             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2012           else
2013 C Other residues
2014 C Compute the Z-axis
2015             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2016             costh=dcos(pi-theta(i+2))
2017             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2018             do k=1,3
2019               uz(k,i)=fac*uz(k,i)
2020             enddo
2021 C Compute the derivatives of uz
2022             uzder(1,1,1)= 0.0d0
2023             uzder(2,1,1)=-dc_norm(3,i+1)
2024             uzder(3,1,1)= dc_norm(2,i+1)
2025             uzder(1,2,1)= dc_norm(3,i+1)
2026             uzder(2,2,1)= 0.0d0
2027             uzder(3,2,1)=-dc_norm(1,i+1)
2028             uzder(1,3,1)=-dc_norm(2,i+1)
2029             uzder(2,3,1)= dc_norm(1,i+1)
2030             uzder(3,3,1)= 0.0d0
2031             uzder(1,1,2)= 0.0d0
2032             uzder(2,1,2)= dc_norm(3,i)
2033             uzder(3,1,2)=-dc_norm(2,i)
2034             uzder(1,2,2)=-dc_norm(3,i)
2035             uzder(2,2,2)= 0.0d0
2036             uzder(3,2,2)= dc_norm(1,i)
2037             uzder(1,3,2)= dc_norm(2,i)
2038             uzder(2,3,2)=-dc_norm(1,i)
2039             uzder(3,3,2)= 0.0d0
2040 C Compute the Y-axis
2041             facy=fac
2042             do k=1,3
2043               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2044             enddo
2045 C Compute the derivatives of uy
2046             do j=1,3
2047               do k=1,3
2048                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2049      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2050                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2051               enddo
2052               uyder(j,j,1)=uyder(j,j,1)-costh
2053               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2054             enddo
2055             do j=1,2
2056               do k=1,3
2057                 do l=1,3
2058                   uygrad(l,k,j,i)=uyder(l,k,j)
2059                   uzgrad(l,k,j,i)=uzder(l,k,j)
2060                 enddo
2061               enddo
2062             enddo
2063             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2064             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2065             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2066             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2067           endif
2068       enddo
2069       do i=1,nres-1
2070         vbld_inv_temp(1)=vbld_inv(i+1)
2071         if (i.lt.nres-1) then
2072           vbld_inv_temp(2)=vbld_inv(i+2)
2073           else
2074           vbld_inv_temp(2)=vbld_inv(i)
2075           endif
2076         do j=1,2
2077           do k=1,3
2078             do l=1,3
2079               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2080               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2081             enddo
2082           enddo
2083         enddo
2084       enddo
2085 #if defined(PARVEC) && defined(MPI)
2086       if (nfgtasks1.gt.1) then
2087         time00=MPI_Wtime()
2088 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2089 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2090 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2091         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2092      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2093      &   FG_COMM1,IERR)
2094         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2095      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2096      &   FG_COMM1,IERR)
2097         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2098      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2099      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2100         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2101      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2102      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2103         time_gather=time_gather+MPI_Wtime()-time00
2104       endif
2105 c      if (fg_rank.eq.0) then
2106 c        write (iout,*) "Arrays UY and UZ"
2107 c        do i=1,nres-1
2108 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2109 c     &     (uz(k,i),k=1,3)
2110 c        enddo
2111 c      endif
2112 #endif
2113       return
2114       end
2115 C-----------------------------------------------------------------------------
2116       subroutine check_vecgrad
2117       implicit real*8 (a-h,o-z)
2118       include 'DIMENSIONS'
2119       include 'COMMON.IOUNITS'
2120       include 'COMMON.GEO'
2121       include 'COMMON.VAR'
2122       include 'COMMON.LOCAL'
2123       include 'COMMON.CHAIN'
2124       include 'COMMON.VECTORS'
2125       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2126       dimension uyt(3,maxres),uzt(3,maxres)
2127       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2128       double precision delta /1.0d-7/
2129       call vec_and_deriv
2130 cd      do i=1,nres
2131 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2132 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2133 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2134 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2135 cd     &     (dc_norm(if90,i),if90=1,3)
2136 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2137 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2138 cd          write(iout,'(a)')
2139 cd      enddo
2140       do i=1,nres
2141         do j=1,2
2142           do k=1,3
2143             do l=1,3
2144               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2145               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2146             enddo
2147           enddo
2148         enddo
2149       enddo
2150       call vec_and_deriv
2151       do i=1,nres
2152         do j=1,3
2153           uyt(j,i)=uy(j,i)
2154           uzt(j,i)=uz(j,i)
2155         enddo
2156       enddo
2157       do i=1,nres
2158 cd        write (iout,*) 'i=',i
2159         do k=1,3
2160           erij(k)=dc_norm(k,i)
2161         enddo
2162         do j=1,3
2163           do k=1,3
2164             dc_norm(k,i)=erij(k)
2165           enddo
2166           dc_norm(j,i)=dc_norm(j,i)+delta
2167 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2168 c          do k=1,3
2169 c            dc_norm(k,i)=dc_norm(k,i)/fac
2170 c          enddo
2171 c          write (iout,*) (dc_norm(k,i),k=1,3)
2172 c          write (iout,*) (erij(k),k=1,3)
2173           call vec_and_deriv
2174           do k=1,3
2175             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2176             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2177             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2178             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2179           enddo
2180 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2181 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2182 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2183         enddo
2184         do k=1,3
2185           dc_norm(k,i)=erij(k)
2186         enddo
2187 cd        do k=1,3
2188 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2189 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2190 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2191 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2192 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2193 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2194 cd          write (iout,'(a)')
2195 cd        enddo
2196       enddo
2197       return
2198       end
2199 C--------------------------------------------------------------------------
2200       subroutine set_matrices
2201       implicit real*8 (a-h,o-z)
2202       include 'DIMENSIONS'
2203 #ifdef MPI
2204       include "mpif.h"
2205       include "COMMON.SETUP"
2206       integer IERR
2207       integer status(MPI_STATUS_SIZE)
2208 #endif
2209       include 'COMMON.IOUNITS'
2210       include 'COMMON.GEO'
2211       include 'COMMON.VAR'
2212       include 'COMMON.LOCAL'
2213       include 'COMMON.CHAIN'
2214       include 'COMMON.DERIV'
2215       include 'COMMON.INTERACT'
2216       include 'COMMON.CONTACTS'
2217       include 'COMMON.TORSION'
2218       include 'COMMON.VECTORS'
2219       include 'COMMON.FFIELD'
2220       double precision auxvec(2),auxmat(2,2)
2221 C
2222 C Compute the virtual-bond-torsional-angle dependent quantities needed
2223 C to calculate the el-loc multibody terms of various order.
2224 C
2225 #ifdef PARMAT
2226       do i=ivec_start+2,ivec_end+2
2227 #else
2228       do i=3,nres+1
2229 #endif
2230         if (i .lt. nres+1) then
2231           sin1=dsin(phi(i))
2232           cos1=dcos(phi(i))
2233           sintab(i-2)=sin1
2234           costab(i-2)=cos1
2235           obrot(1,i-2)=cos1
2236           obrot(2,i-2)=sin1
2237           sin2=dsin(2*phi(i))
2238           cos2=dcos(2*phi(i))
2239           sintab2(i-2)=sin2
2240           costab2(i-2)=cos2
2241           obrot2(1,i-2)=cos2
2242           obrot2(2,i-2)=sin2
2243           Ug(1,1,i-2)=-cos1
2244           Ug(1,2,i-2)=-sin1
2245           Ug(2,1,i-2)=-sin1
2246           Ug(2,2,i-2)= cos1
2247           Ug2(1,1,i-2)=-cos2
2248           Ug2(1,2,i-2)=-sin2
2249           Ug2(2,1,i-2)=-sin2
2250           Ug2(2,2,i-2)= cos2
2251         else
2252           costab(i-2)=1.0d0
2253           sintab(i-2)=0.0d0
2254           obrot(1,i-2)=1.0d0
2255           obrot(2,i-2)=0.0d0
2256           obrot2(1,i-2)=0.0d0
2257           obrot2(2,i-2)=0.0d0
2258           Ug(1,1,i-2)=1.0d0
2259           Ug(1,2,i-2)=0.0d0
2260           Ug(2,1,i-2)=0.0d0
2261           Ug(2,2,i-2)=1.0d0
2262           Ug2(1,1,i-2)=0.0d0
2263           Ug2(1,2,i-2)=0.0d0
2264           Ug2(2,1,i-2)=0.0d0
2265           Ug2(2,2,i-2)=0.0d0
2266         endif
2267         if (i .gt. 3 .and. i .lt. nres+1) then
2268           obrot_der(1,i-2)=-sin1
2269           obrot_der(2,i-2)= cos1
2270           Ugder(1,1,i-2)= sin1
2271           Ugder(1,2,i-2)=-cos1
2272           Ugder(2,1,i-2)=-cos1
2273           Ugder(2,2,i-2)=-sin1
2274           dwacos2=cos2+cos2
2275           dwasin2=sin2+sin2
2276           obrot2_der(1,i-2)=-dwasin2
2277           obrot2_der(2,i-2)= dwacos2
2278           Ug2der(1,1,i-2)= dwasin2
2279           Ug2der(1,2,i-2)=-dwacos2
2280           Ug2der(2,1,i-2)=-dwacos2
2281           Ug2der(2,2,i-2)=-dwasin2
2282         else
2283           obrot_der(1,i-2)=0.0d0
2284           obrot_der(2,i-2)=0.0d0
2285           Ugder(1,1,i-2)=0.0d0
2286           Ugder(1,2,i-2)=0.0d0
2287           Ugder(2,1,i-2)=0.0d0
2288           Ugder(2,2,i-2)=0.0d0
2289           obrot2_der(1,i-2)=0.0d0
2290           obrot2_der(2,i-2)=0.0d0
2291           Ug2der(1,1,i-2)=0.0d0
2292           Ug2der(1,2,i-2)=0.0d0
2293           Ug2der(2,1,i-2)=0.0d0
2294           Ug2der(2,2,i-2)=0.0d0
2295         endif
2296 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2297         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2298           iti = itortyp(itype(i-2))
2299         else
2300           iti=ntortyp+1
2301         endif
2302 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2303         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2304           iti1 = itortyp(itype(i-1))
2305         else
2306           iti1=ntortyp+1
2307         endif
2308 cd        write (iout,*) '*******i',i,' iti1',iti
2309 cd        write (iout,*) 'b1',b1(:,iti)
2310 cd        write (iout,*) 'b2',b2(:,iti)
2311 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2312 c        if (i .gt. iatel_s+2) then
2313         if (i .gt. nnt+2) then
2314           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2315           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2316           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2317      &    then
2318           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2319           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2320           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2321           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2322           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2323           endif
2324         else
2325           do k=1,2
2326             Ub2(k,i-2)=0.0d0
2327             Ctobr(k,i-2)=0.0d0
2328             Dtobr2(k,i-2)=0.0d0
2329             do l=1,2
2330               EUg(l,k,i-2)=0.0d0
2331               CUg(l,k,i-2)=0.0d0
2332               DUg(l,k,i-2)=0.0d0
2333               DtUg2(l,k,i-2)=0.0d0
2334             enddo
2335           enddo
2336         endif
2337         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2338         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2339         do k=1,2
2340           muder(k,i-2)=Ub2der(k,i-2)
2341         enddo
2342 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2343         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2344           iti1 = itortyp(itype(i-1))
2345         else
2346           iti1=ntortyp+1
2347         endif
2348         do k=1,2
2349           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2350         enddo
2351 cd        write (iout,*) 'mu ',mu(:,i-2)
2352 cd        write (iout,*) 'mu1',mu1(:,i-2)
2353 cd        write (iout,*) 'mu2',mu2(:,i-2)
2354         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2355      &  then
2356         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2357         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2358         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2359         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2360         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2361 C Vectors and matrices dependent on a single virtual-bond dihedral.
2362         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2363         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2364         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2365         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2366         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2367         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2368         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2369         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2370         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2371         endif
2372       enddo
2373 C Matrices dependent on two consecutive virtual-bond dihedrals.
2374 C The order of matrices is from left to right.
2375       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2376      &then
2377 c      do i=max0(ivec_start,2),ivec_end
2378       do i=2,nres-1
2379         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2380         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2381         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2382         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2383         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2384         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2385         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2386         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2387       enddo
2388       endif
2389 #if defined(MPI) && defined(PARMAT)
2390 #ifdef DEBUG
2391 c      if (fg_rank.eq.0) then
2392         write (iout,*) "Arrays UG and UGDER before GATHER"
2393         do i=1,nres-1
2394           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2395      &     ((ug(l,k,i),l=1,2),k=1,2),
2396      &     ((ugder(l,k,i),l=1,2),k=1,2)
2397         enddo
2398         write (iout,*) "Arrays UG2 and UG2DER"
2399         do i=1,nres-1
2400           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2401      &     ((ug2(l,k,i),l=1,2),k=1,2),
2402      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2403         enddo
2404         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2405         do i=1,nres-1
2406           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2407      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2408      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2409         enddo
2410         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2411         do i=1,nres-1
2412           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2413      &     costab(i),sintab(i),costab2(i),sintab2(i)
2414         enddo
2415         write (iout,*) "Array MUDER"
2416         do i=1,nres-1
2417           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2418         enddo
2419 c      endif
2420 #endif
2421       if (nfgtasks.gt.1) then
2422         time00=MPI_Wtime()
2423 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2424 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2425 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2426 #ifdef MATGATHER
2427         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2428      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2429      &   FG_COMM1,IERR)
2430         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2431      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2432      &   FG_COMM1,IERR)
2433         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2434      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2435      &   FG_COMM1,IERR)
2436         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2437      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2438      &   FG_COMM1,IERR)
2439         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2440      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2441      &   FG_COMM1,IERR)
2442         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2443      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2444      &   FG_COMM1,IERR)
2445         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2446      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2447      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2448         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2449      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2450      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2451         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2452      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2453      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2454         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2455      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2456      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2457         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2458      &  then
2459         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2460      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2461      &   FG_COMM1,IERR)
2462         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2463      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2464      &   FG_COMM1,IERR)
2465         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2466      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2467      &   FG_COMM1,IERR)
2468        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2469      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2470      &   FG_COMM1,IERR)
2471         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2472      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2473      &   FG_COMM1,IERR)
2474         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2475      &   ivec_count(fg_rank1),
2476      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2477      &   FG_COMM1,IERR)
2478         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2479      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2480      &   FG_COMM1,IERR)
2481         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2482      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2483      &   FG_COMM1,IERR)
2484         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2485      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2486      &   FG_COMM1,IERR)
2487         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2488      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2489      &   FG_COMM1,IERR)
2490         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2491      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2492      &   FG_COMM1,IERR)
2493         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2494      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2495      &   FG_COMM1,IERR)
2496         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2497      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2498      &   FG_COMM1,IERR)
2499         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2500      &   ivec_count(fg_rank1),
2501      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2502      &   FG_COMM1,IERR)
2503         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2504      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2505      &   FG_COMM1,IERR)
2506        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2507      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2508      &   FG_COMM1,IERR)
2509         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2510      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2511      &   FG_COMM1,IERR)
2512        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2513      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2514      &   FG_COMM1,IERR)
2515         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2516      &   ivec_count(fg_rank1),
2517      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2518      &   FG_COMM1,IERR)
2519         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2520      &   ivec_count(fg_rank1),
2521      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2522      &   FG_COMM1,IERR)
2523         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2524      &   ivec_count(fg_rank1),
2525      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2526      &   MPI_MAT2,FG_COMM1,IERR)
2527         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2528      &   ivec_count(fg_rank1),
2529      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2530      &   MPI_MAT2,FG_COMM1,IERR)
2531         endif
2532 #else
2533 c Passes matrix info through the ring
2534       isend=fg_rank1
2535       irecv=fg_rank1-1
2536       if (irecv.lt.0) irecv=nfgtasks1-1
2537       iprev=irecv
2538       inext=fg_rank1+1
2539       if (inext.ge.nfgtasks1) inext=0
2540       do i=1,nfgtasks1-1
2541 c        write (iout,*) "isend",isend," irecv",irecv
2542 c        call flush(iout)
2543         lensend=lentyp(isend)
2544         lenrecv=lentyp(irecv)
2545 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2546 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2547 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2548 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2549 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2550 c        write (iout,*) "Gather ROTAT1"
2551 c        call flush(iout)
2552 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2553 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2554 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2555 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2556 c        write (iout,*) "Gather ROTAT2"
2557 c        call flush(iout)
2558         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2559      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2560      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2561      &   iprev,4400+irecv,FG_COMM,status,IERR)
2562 c        write (iout,*) "Gather ROTAT_OLD"
2563 c        call flush(iout)
2564         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2565      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2566      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2567      &   iprev,5500+irecv,FG_COMM,status,IERR)
2568 c        write (iout,*) "Gather PRECOMP11"
2569 c        call flush(iout)
2570         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2571      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2572      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2573      &   iprev,6600+irecv,FG_COMM,status,IERR)
2574 c        write (iout,*) "Gather PRECOMP12"
2575 c        call flush(iout)
2576         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2577      &  then
2578         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2579      &   MPI_ROTAT2(lensend),inext,7700+isend,
2580      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2581      &   iprev,7700+irecv,FG_COMM,status,IERR)
2582 c        write (iout,*) "Gather PRECOMP21"
2583 c        call flush(iout)
2584         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2585      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2586      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2587      &   iprev,8800+irecv,FG_COMM,status,IERR)
2588 c        write (iout,*) "Gather PRECOMP22"
2589 c        call flush(iout)
2590         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2591      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2592      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2593      &   MPI_PRECOMP23(lenrecv),
2594      &   iprev,9900+irecv,FG_COMM,status,IERR)
2595 c        write (iout,*) "Gather PRECOMP23"
2596 c        call flush(iout)
2597         endif
2598         isend=irecv
2599         irecv=irecv-1
2600         if (irecv.lt.0) irecv=nfgtasks1-1
2601       enddo
2602 #endif
2603         time_gather=time_gather+MPI_Wtime()-time00
2604       endif
2605 #ifdef DEBUG
2606 c      if (fg_rank.eq.0) then
2607         write (iout,*) "Arrays UG and UGDER"
2608         do i=1,nres-1
2609           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2610      &     ((ug(l,k,i),l=1,2),k=1,2),
2611      &     ((ugder(l,k,i),l=1,2),k=1,2)
2612         enddo
2613         write (iout,*) "Arrays UG2 and UG2DER"
2614         do i=1,nres-1
2615           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2616      &     ((ug2(l,k,i),l=1,2),k=1,2),
2617      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2618         enddo
2619         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2620         do i=1,nres-1
2621           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2622      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2623      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2624         enddo
2625         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2626         do i=1,nres-1
2627           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2628      &     costab(i),sintab(i),costab2(i),sintab2(i)
2629         enddo
2630         write (iout,*) "Array MUDER"
2631         do i=1,nres-1
2632           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2633         enddo
2634 c      endif
2635 #endif
2636 #endif
2637 cd      do i=1,nres
2638 cd        iti = itortyp(itype(i))
2639 cd        write (iout,*) i
2640 cd        do j=1,2
2641 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2642 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2643 cd        enddo
2644 cd      enddo
2645       return
2646       end
2647 C--------------------------------------------------------------------------
2648       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2649 C
2650 C This subroutine calculates the average interaction energy and its gradient
2651 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2652 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2653 C The potential depends both on the distance of peptide-group centers and on
2654 C the orientation of the CA-CA virtual bonds.
2655 C
2656       implicit real*8 (a-h,o-z)
2657 #ifdef MPI
2658       include 'mpif.h'
2659 #endif
2660       include 'DIMENSIONS'
2661       include 'COMMON.CONTROL'
2662       include 'COMMON.SETUP'
2663       include 'COMMON.IOUNITS'
2664       include 'COMMON.GEO'
2665       include 'COMMON.VAR'
2666       include 'COMMON.LOCAL'
2667       include 'COMMON.CHAIN'
2668       include 'COMMON.DERIV'
2669       include 'COMMON.INTERACT'
2670       include 'COMMON.CONTACTS'
2671       include 'COMMON.TORSION'
2672       include 'COMMON.VECTORS'
2673       include 'COMMON.FFIELD'
2674       include 'COMMON.TIME1'
2675       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2676      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2677       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2678      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2679       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2680      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2681      &    num_conti,j1,j2
2682 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2683 #ifdef MOMENT
2684       double precision scal_el /1.0d0/
2685 #else
2686       double precision scal_el /0.5d0/
2687 #endif
2688 C 12/13/98
2689 C 13-go grudnia roku pamietnego...
2690       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2691      &                   0.0d0,1.0d0,0.0d0,
2692      &                   0.0d0,0.0d0,1.0d0/
2693 cd      write(iout,*) 'In EELEC'
2694 cd      do i=1,nloctyp
2695 cd        write(iout,*) 'Type',i
2696 cd        write(iout,*) 'B1',B1(:,i)
2697 cd        write(iout,*) 'B2',B2(:,i)
2698 cd        write(iout,*) 'CC',CC(:,:,i)
2699 cd        write(iout,*) 'DD',DD(:,:,i)
2700 cd        write(iout,*) 'EE',EE(:,:,i)
2701 cd      enddo
2702 cd      call check_vecgrad
2703 cd      stop
2704       if (icheckgrad.eq.1) then
2705         do i=1,nres-1
2706           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2707           do k=1,3
2708             dc_norm(k,i)=dc(k,i)*fac
2709           enddo
2710 c          write (iout,*) 'i',i,' fac',fac
2711         enddo
2712       endif
2713       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2714      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2715      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2716 c        call vec_and_deriv
2717 #ifdef TIMING
2718         time01=MPI_Wtime()
2719 #endif
2720         call set_matrices
2721 #ifdef TIMING
2722         time_mat=time_mat+MPI_Wtime()-time01
2723 #endif
2724       endif
2725 cd      do i=1,nres-1
2726 cd        write (iout,*) 'i=',i
2727 cd        do k=1,3
2728 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2729 cd        enddo
2730 cd        do k=1,3
2731 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2732 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2733 cd        enddo
2734 cd      enddo
2735       t_eelecij=0.0d0
2736       ees=0.0D0
2737       evdw1=0.0D0
2738       eel_loc=0.0d0
2739       eello_turn3=0.0d0
2740       eello_turn4=0.0d0
2741       ind=0
2742       do i=1,nres
2743         num_cont_hb(i)=0
2744       enddo
2745 cd      print '(a)','Enter EELEC'
2746 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2747       do i=1,nres
2748         gel_loc_loc(i)=0.0d0
2749         gcorr_loc(i)=0.0d0
2750       enddo
2751 c
2752 c
2753 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2754 C
2755 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2756 C
2757       do i=iturn3_start,iturn3_end
2758         if (itype(i).eq.21 .or. itype(i+1).eq.21
2759      &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21) cycle
2760         dxi=dc(1,i)
2761         dyi=dc(2,i)
2762         dzi=dc(3,i)
2763         dx_normi=dc_norm(1,i)
2764         dy_normi=dc_norm(2,i)
2765         dz_normi=dc_norm(3,i)
2766         xmedi=c(1,i)+0.5d0*dxi
2767         ymedi=c(2,i)+0.5d0*dyi
2768         zmedi=c(3,i)+0.5d0*dzi
2769         num_conti=0
2770         call eelecij(i,i+2,ees,evdw1,eel_loc)
2771         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2772         num_cont_hb(i)=num_conti
2773       enddo
2774       do i=iturn4_start,iturn4_end
2775         if (itype(i).eq.21 .or. itype(i+1).eq.21
2776      &    .or. itype(i+3).eq.21
2777      &    .or. itype(i+4).eq.21) cycle
2778         dxi=dc(1,i)
2779         dyi=dc(2,i)
2780         dzi=dc(3,i)
2781         dx_normi=dc_norm(1,i)
2782         dy_normi=dc_norm(2,i)
2783         dz_normi=dc_norm(3,i)
2784         xmedi=c(1,i)+0.5d0*dxi
2785         ymedi=c(2,i)+0.5d0*dyi
2786         zmedi=c(3,i)+0.5d0*dzi
2787         num_conti=num_cont_hb(i)
2788         call eelecij(i,i+3,ees,evdw1,eel_loc)
2789         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.21)
2790      &   call eturn4(i,eello_turn4)
2791         num_cont_hb(i)=num_conti
2792       enddo   ! i
2793 c
2794 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2795 c
2796       do i=iatel_s,iatel_e
2797         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
2798         dxi=dc(1,i)
2799         dyi=dc(2,i)
2800         dzi=dc(3,i)
2801         dx_normi=dc_norm(1,i)
2802         dy_normi=dc_norm(2,i)
2803         dz_normi=dc_norm(3,i)
2804         xmedi=c(1,i)+0.5d0*dxi
2805         ymedi=c(2,i)+0.5d0*dyi
2806         zmedi=c(3,i)+0.5d0*dzi
2807 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2808         num_conti=num_cont_hb(i)
2809         do j=ielstart(i),ielend(i)
2810 c          write (iout,*) i,j,itype(i),itype(j)
2811           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
2812           call eelecij(i,j,ees,evdw1,eel_loc)
2813         enddo ! j
2814         num_cont_hb(i)=num_conti
2815       enddo   ! i
2816 c      write (iout,*) "Number of loop steps in EELEC:",ind
2817 cd      do i=1,nres
2818 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2819 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2820 cd      enddo
2821 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2822 ccc      eel_loc=eel_loc+eello_turn3
2823 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2824       return
2825       end
2826 C-------------------------------------------------------------------------------
2827       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2828       implicit real*8 (a-h,o-z)
2829       include 'DIMENSIONS'
2830 #ifdef MPI
2831       include "mpif.h"
2832 #endif
2833       include 'COMMON.CONTROL'
2834       include 'COMMON.IOUNITS'
2835       include 'COMMON.GEO'
2836       include 'COMMON.VAR'
2837       include 'COMMON.LOCAL'
2838       include 'COMMON.CHAIN'
2839       include 'COMMON.DERIV'
2840       include 'COMMON.INTERACT'
2841       include 'COMMON.CONTACTS'
2842       include 'COMMON.TORSION'
2843       include 'COMMON.VECTORS'
2844       include 'COMMON.FFIELD'
2845       include 'COMMON.TIME1'
2846       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2847      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2848       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2849      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2850       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2851      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2852      &    num_conti,j1,j2
2853 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2854 #ifdef MOMENT
2855       double precision scal_el /1.0d0/
2856 #else
2857       double precision scal_el /0.5d0/
2858 #endif
2859 C 12/13/98
2860 C 13-go grudnia roku pamietnego...
2861       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2862      &                   0.0d0,1.0d0,0.0d0,
2863      &                   0.0d0,0.0d0,1.0d0/
2864 c          time00=MPI_Wtime()
2865 cd      write (iout,*) "eelecij",i,j
2866 c          ind=ind+1
2867           iteli=itel(i)
2868           itelj=itel(j)
2869           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2870           aaa=app(iteli,itelj)
2871           bbb=bpp(iteli,itelj)
2872           ael6i=ael6(iteli,itelj)
2873           ael3i=ael3(iteli,itelj)
2874           dxj=dc(1,j)
2875           dyj=dc(2,j)
2876           dzj=dc(3,j)
2877           dx_normj=dc_norm(1,j)
2878           dy_normj=dc_norm(2,j)
2879           dz_normj=dc_norm(3,j)
2880           xj=c(1,j)+0.5D0*dxj-xmedi
2881           yj=c(2,j)+0.5D0*dyj-ymedi
2882           zj=c(3,j)+0.5D0*dzj-zmedi
2883           rij=xj*xj+yj*yj+zj*zj
2884           rrmij=1.0D0/rij
2885           rij=dsqrt(rij)
2886           rmij=1.0D0/rij
2887           r3ij=rrmij*rmij
2888           r6ij=r3ij*r3ij
2889           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2890           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2891           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2892           fac=cosa-3.0D0*cosb*cosg
2893           ev1=aaa*r6ij*r6ij
2894 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2895           if (j.eq.i+2) ev1=scal_el*ev1
2896           ev2=bbb*r6ij
2897           fac3=ael6i*r6ij
2898           fac4=ael3i*r3ij
2899           evdwij=ev1+ev2
2900           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2901           el2=fac4*fac
2902           eesij=el1+el2
2903 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2904           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2905           ees=ees+eesij
2906           evdw1=evdw1+evdwij
2907 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2908 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2909 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2910 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2911
2912           if (energy_dec) then
2913               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2914               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2915           endif
2916
2917 C
2918 C Calculate contributions to the Cartesian gradient.
2919 C
2920 #ifdef SPLITELE
2921           facvdw=-6*rrmij*(ev1+evdwij)
2922           facel=-3*rrmij*(el1+eesij)
2923           fac1=fac
2924           erij(1)=xj*rmij
2925           erij(2)=yj*rmij
2926           erij(3)=zj*rmij
2927 *
2928 * Radial derivatives. First process both termini of the fragment (i,j)
2929 *
2930           ggg(1)=facel*xj
2931           ggg(2)=facel*yj
2932           ggg(3)=facel*zj
2933 c          do k=1,3
2934 c            ghalf=0.5D0*ggg(k)
2935 c            gelc(k,i)=gelc(k,i)+ghalf
2936 c            gelc(k,j)=gelc(k,j)+ghalf
2937 c          enddo
2938 c 9/28/08 AL Gradient compotents will be summed only at the end
2939           do k=1,3
2940             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2941             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2942           enddo
2943 *
2944 * Loop over residues i+1 thru j-1.
2945 *
2946 cgrad          do k=i+1,j-1
2947 cgrad            do l=1,3
2948 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2949 cgrad            enddo
2950 cgrad          enddo
2951           ggg(1)=facvdw*xj
2952           ggg(2)=facvdw*yj
2953           ggg(3)=facvdw*zj
2954 c          do k=1,3
2955 c            ghalf=0.5D0*ggg(k)
2956 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2957 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2958 c          enddo
2959 c 9/28/08 AL Gradient compotents will be summed only at the end
2960           do k=1,3
2961             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2962             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2963           enddo
2964 *
2965 * Loop over residues i+1 thru j-1.
2966 *
2967 cgrad          do k=i+1,j-1
2968 cgrad            do l=1,3
2969 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2970 cgrad            enddo
2971 cgrad          enddo
2972 #else
2973           facvdw=ev1+evdwij
2974           facel=el1+eesij
2975           fac1=fac
2976           fac=-3*rrmij*(facvdw+facvdw+facel)
2977           erij(1)=xj*rmij
2978           erij(2)=yj*rmij
2979           erij(3)=zj*rmij
2980 *
2981 * Radial derivatives. First process both termini of the fragment (i,j)
2982 *
2983           ggg(1)=fac*xj
2984           ggg(2)=fac*yj
2985           ggg(3)=fac*zj
2986 c          do k=1,3
2987 c            ghalf=0.5D0*ggg(k)
2988 c            gelc(k,i)=gelc(k,i)+ghalf
2989 c            gelc(k,j)=gelc(k,j)+ghalf
2990 c          enddo
2991 c 9/28/08 AL Gradient compotents will be summed only at the end
2992           do k=1,3
2993             gelc_long(k,j)=gelc(k,j)+ggg(k)
2994             gelc_long(k,i)=gelc(k,i)-ggg(k)
2995           enddo
2996 *
2997 * Loop over residues i+1 thru j-1.
2998 *
2999 cgrad          do k=i+1,j-1
3000 cgrad            do l=1,3
3001 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3002 cgrad            enddo
3003 cgrad          enddo
3004 c 9/28/08 AL Gradient compotents will be summed only at the end
3005           ggg(1)=facvdw*xj
3006           ggg(2)=facvdw*yj
3007           ggg(3)=facvdw*zj
3008           do k=1,3
3009             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3010             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3011           enddo
3012 #endif
3013 *
3014 * Angular part
3015 *
3016           ecosa=2.0D0*fac3*fac1+fac4
3017           fac4=-3.0D0*fac4
3018           fac3=-6.0D0*fac3
3019           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3020           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3021           do k=1,3
3022             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3023             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3024           enddo
3025 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3026 cd   &          (dcosg(k),k=1,3)
3027           do k=1,3
3028             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3029           enddo
3030 c          do k=1,3
3031 c            ghalf=0.5D0*ggg(k)
3032 c            gelc(k,i)=gelc(k,i)+ghalf
3033 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3034 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3035 c            gelc(k,j)=gelc(k,j)+ghalf
3036 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3037 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3038 c          enddo
3039 cgrad          do k=i+1,j-1
3040 cgrad            do l=1,3
3041 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3042 cgrad            enddo
3043 cgrad          enddo
3044           do k=1,3
3045             gelc(k,i)=gelc(k,i)
3046      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3047      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3048             gelc(k,j)=gelc(k,j)
3049      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3050      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3051             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3052             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3053           enddo
3054           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3055      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3056      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3057 C
3058 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3059 C   energy of a peptide unit is assumed in the form of a second-order
3060 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3061 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3062 C   are computed for EVERY pair of non-contiguous peptide groups.
3063 C
3064           if (j.lt.nres-1) then
3065             j1=j+1
3066             j2=j-1
3067           else
3068             j1=j-1
3069             j2=j-2
3070           endif
3071           kkk=0
3072           do k=1,2
3073             do l=1,2
3074               kkk=kkk+1
3075               muij(kkk)=mu(k,i)*mu(l,j)
3076             enddo
3077           enddo
3078 cd         write (iout,*) 'EELEC: i',i,' j',j
3079 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3080 cd          write(iout,*) 'muij',muij
3081           ury=scalar(uy(1,i),erij)
3082           urz=scalar(uz(1,i),erij)
3083           vry=scalar(uy(1,j),erij)
3084           vrz=scalar(uz(1,j),erij)
3085           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3086           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3087           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3088           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3089           fac=dsqrt(-ael6i)*r3ij
3090           a22=a22*fac
3091           a23=a23*fac
3092           a32=a32*fac
3093           a33=a33*fac
3094 cd          write (iout,'(4i5,4f10.5)')
3095 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3096 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3097 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3098 cd     &      uy(:,j),uz(:,j)
3099 cd          write (iout,'(4f10.5)')
3100 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3101 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3102 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3103 cd           write (iout,'(9f10.5/)')
3104 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3105 C Derivatives of the elements of A in virtual-bond vectors
3106           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3107           do k=1,3
3108             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3109             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3110             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3111             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3112             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3113             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3114             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3115             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3116             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3117             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3118             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3119             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3120           enddo
3121 C Compute radial contributions to the gradient
3122           facr=-3.0d0*rrmij
3123           a22der=a22*facr
3124           a23der=a23*facr
3125           a32der=a32*facr
3126           a33der=a33*facr
3127           agg(1,1)=a22der*xj
3128           agg(2,1)=a22der*yj
3129           agg(3,1)=a22der*zj
3130           agg(1,2)=a23der*xj
3131           agg(2,2)=a23der*yj
3132           agg(3,2)=a23der*zj
3133           agg(1,3)=a32der*xj
3134           agg(2,3)=a32der*yj
3135           agg(3,3)=a32der*zj
3136           agg(1,4)=a33der*xj
3137           agg(2,4)=a33der*yj
3138           agg(3,4)=a33der*zj
3139 C Add the contributions coming from er
3140           fac3=-3.0d0*fac
3141           do k=1,3
3142             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3143             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3144             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3145             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3146           enddo
3147           do k=1,3
3148 C Derivatives in DC(i)
3149 cgrad            ghalf1=0.5d0*agg(k,1)
3150 cgrad            ghalf2=0.5d0*agg(k,2)
3151 cgrad            ghalf3=0.5d0*agg(k,3)
3152 cgrad            ghalf4=0.5d0*agg(k,4)
3153             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3154      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3155             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3156      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3157             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3158      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3159             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3160      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3161 C Derivatives in DC(i+1)
3162             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3163      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3164             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3165      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3166             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3167      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3168             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3169      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3170 C Derivatives in DC(j)
3171             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3172      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3173             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3174      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3175             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3176      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3177             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3178      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3179 C Derivatives in DC(j+1) or DC(nres-1)
3180             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3181      &      -3.0d0*vryg(k,3)*ury)
3182             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3183      &      -3.0d0*vrzg(k,3)*ury)
3184             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3185      &      -3.0d0*vryg(k,3)*urz)
3186             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3187      &      -3.0d0*vrzg(k,3)*urz)
3188 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3189 cgrad              do l=1,4
3190 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3191 cgrad              enddo
3192 cgrad            endif
3193           enddo
3194           acipa(1,1)=a22
3195           acipa(1,2)=a23
3196           acipa(2,1)=a32
3197           acipa(2,2)=a33
3198           a22=-a22
3199           a23=-a23
3200           do l=1,2
3201             do k=1,3
3202               agg(k,l)=-agg(k,l)
3203               aggi(k,l)=-aggi(k,l)
3204               aggi1(k,l)=-aggi1(k,l)
3205               aggj(k,l)=-aggj(k,l)
3206               aggj1(k,l)=-aggj1(k,l)
3207             enddo
3208           enddo
3209           if (j.lt.nres-1) then
3210             a22=-a22
3211             a32=-a32
3212             do l=1,3,2
3213               do k=1,3
3214                 agg(k,l)=-agg(k,l)
3215                 aggi(k,l)=-aggi(k,l)
3216                 aggi1(k,l)=-aggi1(k,l)
3217                 aggj(k,l)=-aggj(k,l)
3218                 aggj1(k,l)=-aggj1(k,l)
3219               enddo
3220             enddo
3221           else
3222             a22=-a22
3223             a23=-a23
3224             a32=-a32
3225             a33=-a33
3226             do l=1,4
3227               do k=1,3
3228                 agg(k,l)=-agg(k,l)
3229                 aggi(k,l)=-aggi(k,l)
3230                 aggi1(k,l)=-aggi1(k,l)
3231                 aggj(k,l)=-aggj(k,l)
3232                 aggj1(k,l)=-aggj1(k,l)
3233               enddo
3234             enddo
3235           endif
3236           ENDIF ! WCORR
3237           IF (wel_loc.gt.0.0d0) THEN
3238 C Contribution to the local-electrostatic energy coming from the i-j pair
3239           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3240      &     +a33*muij(4)
3241 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3242
3243           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3244      &            'eelloc',i,j,eel_loc_ij
3245
3246           eel_loc=eel_loc+eel_loc_ij
3247 C Partial derivatives in virtual-bond dihedral angles gamma
3248           if (i.gt.1)
3249      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3250      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3251      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3252           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3253      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3254      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3255 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3256           do l=1,3
3257             ggg(l)=agg(l,1)*muij(1)+
3258      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3259             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3260             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3261 cgrad            ghalf=0.5d0*ggg(l)
3262 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3263 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3264           enddo
3265 cgrad          do k=i+1,j2
3266 cgrad            do l=1,3
3267 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3268 cgrad            enddo
3269 cgrad          enddo
3270 C Remaining derivatives of eello
3271           do l=1,3
3272             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3273      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3274             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3275      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3276             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3277      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3278             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3279      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3280           enddo
3281           ENDIF
3282 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3283 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3284           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3285      &       .and. num_conti.le.maxconts) then
3286 c            write (iout,*) i,j," entered corr"
3287 C
3288 C Calculate the contact function. The ith column of the array JCONT will
3289 C contain the numbers of atoms that make contacts with the atom I (of numbers
3290 C greater than I). The arrays FACONT and GACONT will contain the values of
3291 C the contact function and its derivative.
3292 c           r0ij=1.02D0*rpp(iteli,itelj)
3293 c           r0ij=1.11D0*rpp(iteli,itelj)
3294             r0ij=2.20D0*rpp(iteli,itelj)
3295 c           r0ij=1.55D0*rpp(iteli,itelj)
3296             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3297             if (fcont.gt.0.0D0) then
3298               num_conti=num_conti+1
3299               if (num_conti.gt.maxconts) then
3300                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3301      &                         ' will skip next contacts for this conf.'
3302               else
3303                 jcont_hb(num_conti,i)=j
3304 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3305 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3306                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3307      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3308 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3309 C  terms.
3310                 d_cont(num_conti,i)=rij
3311 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3312 C     --- Electrostatic-interaction matrix ---
3313                 a_chuj(1,1,num_conti,i)=a22
3314                 a_chuj(1,2,num_conti,i)=a23
3315                 a_chuj(2,1,num_conti,i)=a32
3316                 a_chuj(2,2,num_conti,i)=a33
3317 C     --- Gradient of rij
3318                 do kkk=1,3
3319                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3320                 enddo
3321                 kkll=0
3322                 do k=1,2
3323                   do l=1,2
3324                     kkll=kkll+1
3325                     do m=1,3
3326                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3327                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3328                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3329                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3330                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3331                     enddo
3332                   enddo
3333                 enddo
3334                 ENDIF
3335                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3336 C Calculate contact energies
3337                 cosa4=4.0D0*cosa
3338                 wij=cosa-3.0D0*cosb*cosg
3339                 cosbg1=cosb+cosg
3340                 cosbg2=cosb-cosg
3341 c               fac3=dsqrt(-ael6i)/r0ij**3
3342                 fac3=dsqrt(-ael6i)*r3ij
3343 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3344                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3345                 if (ees0tmp.gt.0) then
3346                   ees0pij=dsqrt(ees0tmp)
3347                 else
3348                   ees0pij=0
3349                 endif
3350 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3351                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3352                 if (ees0tmp.gt.0) then
3353                   ees0mij=dsqrt(ees0tmp)
3354                 else
3355                   ees0mij=0
3356                 endif
3357 c               ees0mij=0.0D0
3358                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3359                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3360 C Diagnostics. Comment out or remove after debugging!
3361 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3362 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3363 c               ees0m(num_conti,i)=0.0D0
3364 C End diagnostics.
3365 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3366 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3367 C Angular derivatives of the contact function
3368                 ees0pij1=fac3/ees0pij
3369                 ees0mij1=fac3/ees0mij
3370                 fac3p=-3.0D0*fac3*rrmij
3371                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3372                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3373 c               ees0mij1=0.0D0
3374                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3375                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3376                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3377                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3378                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3379                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3380                 ecosap=ecosa1+ecosa2
3381                 ecosbp=ecosb1+ecosb2
3382                 ecosgp=ecosg1+ecosg2
3383                 ecosam=ecosa1-ecosa2
3384                 ecosbm=ecosb1-ecosb2
3385                 ecosgm=ecosg1-ecosg2
3386 C Diagnostics
3387 c               ecosap=ecosa1
3388 c               ecosbp=ecosb1
3389 c               ecosgp=ecosg1
3390 c               ecosam=0.0D0
3391 c               ecosbm=0.0D0
3392 c               ecosgm=0.0D0
3393 C End diagnostics
3394                 facont_hb(num_conti,i)=fcont
3395                 fprimcont=fprimcont/rij
3396 cd              facont_hb(num_conti,i)=1.0D0
3397 C Following line is for diagnostics.
3398 cd              fprimcont=0.0D0
3399                 do k=1,3
3400                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3401                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3402                 enddo
3403                 do k=1,3
3404                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3405                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3406                 enddo
3407                 gggp(1)=gggp(1)+ees0pijp*xj
3408                 gggp(2)=gggp(2)+ees0pijp*yj
3409                 gggp(3)=gggp(3)+ees0pijp*zj
3410                 gggm(1)=gggm(1)+ees0mijp*xj
3411                 gggm(2)=gggm(2)+ees0mijp*yj
3412                 gggm(3)=gggm(3)+ees0mijp*zj
3413 C Derivatives due to the contact function
3414                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3415                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3416                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3417                 do k=1,3
3418 c
3419 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3420 c          following the change of gradient-summation algorithm.
3421 c
3422 cgrad                  ghalfp=0.5D0*gggp(k)
3423 cgrad                  ghalfm=0.5D0*gggm(k)
3424                   gacontp_hb1(k,num_conti,i)=!ghalfp
3425      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3426      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3427                   gacontp_hb2(k,num_conti,i)=!ghalfp
3428      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3429      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3430                   gacontp_hb3(k,num_conti,i)=gggp(k)
3431                   gacontm_hb1(k,num_conti,i)=!ghalfm
3432      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3433      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3434                   gacontm_hb2(k,num_conti,i)=!ghalfm
3435      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3436      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3437                   gacontm_hb3(k,num_conti,i)=gggm(k)
3438                 enddo
3439 C Diagnostics. Comment out or remove after debugging!
3440 cdiag           do k=1,3
3441 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3442 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3443 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3444 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3445 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3446 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3447 cdiag           enddo
3448               ENDIF ! wcorr
3449               endif  ! num_conti.le.maxconts
3450             endif  ! fcont.gt.0
3451           endif    ! j.gt.i+1
3452           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3453             do k=1,4
3454               do l=1,3
3455                 ghalf=0.5d0*agg(l,k)
3456                 aggi(l,k)=aggi(l,k)+ghalf
3457                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3458                 aggj(l,k)=aggj(l,k)+ghalf
3459               enddo
3460             enddo
3461             if (j.eq.nres-1 .and. i.lt.j-2) then
3462               do k=1,4
3463                 do l=1,3
3464                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3465                 enddo
3466               enddo
3467             endif
3468           endif
3469 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3470       return
3471       end
3472 C-----------------------------------------------------------------------------
3473       subroutine eturn3(i,eello_turn3)
3474 C Third- and fourth-order contributions from turns
3475       implicit real*8 (a-h,o-z)
3476       include 'DIMENSIONS'
3477       include 'COMMON.IOUNITS'
3478       include 'COMMON.GEO'
3479       include 'COMMON.VAR'
3480       include 'COMMON.LOCAL'
3481       include 'COMMON.CHAIN'
3482       include 'COMMON.DERIV'
3483       include 'COMMON.INTERACT'
3484       include 'COMMON.CONTACTS'
3485       include 'COMMON.TORSION'
3486       include 'COMMON.VECTORS'
3487       include 'COMMON.FFIELD'
3488       include 'COMMON.CONTROL'
3489       dimension ggg(3)
3490       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3491      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3492      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3493       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3494      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3495       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3496      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3497      &    num_conti,j1,j2
3498       j=i+2
3499 c      write (iout,*) "eturn3",i,j,j1,j2
3500       a_temp(1,1)=a22
3501       a_temp(1,2)=a23
3502       a_temp(2,1)=a32
3503       a_temp(2,2)=a33
3504 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3505 C
3506 C               Third-order contributions
3507 C
3508 C                 (i+2)o----(i+3)
3509 C                      | |
3510 C                      | |
3511 C                 (i+1)o----i
3512 C
3513 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3514 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3515         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3516         call transpose2(auxmat(1,1),auxmat1(1,1))
3517         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3518         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3519         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3520      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3521 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3522 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3523 cd     &    ' eello_turn3_num',4*eello_turn3_num
3524 C Derivatives in gamma(i)
3525         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3526         call transpose2(auxmat2(1,1),auxmat3(1,1))
3527         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3528         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3529 C Derivatives in gamma(i+1)
3530         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3531         call transpose2(auxmat2(1,1),auxmat3(1,1))
3532         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3533         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3534      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3535 C Cartesian derivatives
3536         do l=1,3
3537 c            ghalf1=0.5d0*agg(l,1)
3538 c            ghalf2=0.5d0*agg(l,2)
3539 c            ghalf3=0.5d0*agg(l,3)
3540 c            ghalf4=0.5d0*agg(l,4)
3541           a_temp(1,1)=aggi(l,1)!+ghalf1
3542           a_temp(1,2)=aggi(l,2)!+ghalf2
3543           a_temp(2,1)=aggi(l,3)!+ghalf3
3544           a_temp(2,2)=aggi(l,4)!+ghalf4
3545           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3546           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3547      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3548           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3549           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3550           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3551           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3552           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3553           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3554      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3555           a_temp(1,1)=aggj(l,1)!+ghalf1
3556           a_temp(1,2)=aggj(l,2)!+ghalf2
3557           a_temp(2,1)=aggj(l,3)!+ghalf3
3558           a_temp(2,2)=aggj(l,4)!+ghalf4
3559           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3560           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3561      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3562           a_temp(1,1)=aggj1(l,1)
3563           a_temp(1,2)=aggj1(l,2)
3564           a_temp(2,1)=aggj1(l,3)
3565           a_temp(2,2)=aggj1(l,4)
3566           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3567           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3568      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3569         enddo
3570       return
3571       end
3572 C-------------------------------------------------------------------------------
3573       subroutine eturn4(i,eello_turn4)
3574 C Third- and fourth-order contributions from turns
3575       implicit real*8 (a-h,o-z)
3576       include 'DIMENSIONS'
3577       include 'COMMON.IOUNITS'
3578       include 'COMMON.GEO'
3579       include 'COMMON.VAR'
3580       include 'COMMON.LOCAL'
3581       include 'COMMON.CHAIN'
3582       include 'COMMON.DERIV'
3583       include 'COMMON.INTERACT'
3584       include 'COMMON.CONTACTS'
3585       include 'COMMON.TORSION'
3586       include 'COMMON.VECTORS'
3587       include 'COMMON.FFIELD'
3588       include 'COMMON.CONTROL'
3589       dimension ggg(3)
3590       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3591      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3592      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3593       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3594      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3595       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3596      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3597      &    num_conti,j1,j2
3598       j=i+3
3599 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3600 C
3601 C               Fourth-order contributions
3602 C
3603 C                 (i+3)o----(i+4)
3604 C                     /  |
3605 C               (i+2)o   |
3606 C                     \  |
3607 C                 (i+1)o----i
3608 C
3609 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3610 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3611 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3612         a_temp(1,1)=a22
3613         a_temp(1,2)=a23
3614         a_temp(2,1)=a32
3615         a_temp(2,2)=a33
3616         iti1=itortyp(itype(i+1))
3617         iti2=itortyp(itype(i+2))
3618         iti3=itortyp(itype(i+3))
3619 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3620         call transpose2(EUg(1,1,i+1),e1t(1,1))
3621         call transpose2(Eug(1,1,i+2),e2t(1,1))
3622         call transpose2(Eug(1,1,i+3),e3t(1,1))
3623         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3624         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3625         s1=scalar2(b1(1,iti2),auxvec(1))
3626         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3627         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3628         s2=scalar2(b1(1,iti1),auxvec(1))
3629         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3630         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3631         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3632         eello_turn4=eello_turn4-(s1+s2+s3)
3633         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3634      &      'eturn4',i,j,-(s1+s2+s3)
3635 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3636 cd     &    ' eello_turn4_num',8*eello_turn4_num
3637 C Derivatives in gamma(i)
3638         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3639         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3640         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3641         s1=scalar2(b1(1,iti2),auxvec(1))
3642         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3643         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3644         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3645 C Derivatives in gamma(i+1)
3646         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3647         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3648         s2=scalar2(b1(1,iti1),auxvec(1))
3649         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3650         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3651         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3652         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3653 C Derivatives in gamma(i+2)
3654         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3655         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3656         s1=scalar2(b1(1,iti2),auxvec(1))
3657         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3658         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3659         s2=scalar2(b1(1,iti1),auxvec(1))
3660         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3661         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3662         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3663         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3664 C Cartesian derivatives
3665 C Derivatives of this turn contributions in DC(i+2)
3666         if (j.lt.nres-1) then
3667           do l=1,3
3668             a_temp(1,1)=agg(l,1)
3669             a_temp(1,2)=agg(l,2)
3670             a_temp(2,1)=agg(l,3)
3671             a_temp(2,2)=agg(l,4)
3672             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3673             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3674             s1=scalar2(b1(1,iti2),auxvec(1))
3675             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3676             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3677             s2=scalar2(b1(1,iti1),auxvec(1))
3678             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3679             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3680             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3681             ggg(l)=-(s1+s2+s3)
3682             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3683           enddo
3684         endif
3685 C Remaining derivatives of this turn contribution
3686         do l=1,3
3687           a_temp(1,1)=aggi(l,1)
3688           a_temp(1,2)=aggi(l,2)
3689           a_temp(2,1)=aggi(l,3)
3690           a_temp(2,2)=aggi(l,4)
3691           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3692           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3693           s1=scalar2(b1(1,iti2),auxvec(1))
3694           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3695           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3696           s2=scalar2(b1(1,iti1),auxvec(1))
3697           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3698           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3699           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3700           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3701           a_temp(1,1)=aggi1(l,1)
3702           a_temp(1,2)=aggi1(l,2)
3703           a_temp(2,1)=aggi1(l,3)
3704           a_temp(2,2)=aggi1(l,4)
3705           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3706           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3707           s1=scalar2(b1(1,iti2),auxvec(1))
3708           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3709           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3710           s2=scalar2(b1(1,iti1),auxvec(1))
3711           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3712           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3713           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3714           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3715           a_temp(1,1)=aggj(l,1)
3716           a_temp(1,2)=aggj(l,2)
3717           a_temp(2,1)=aggj(l,3)
3718           a_temp(2,2)=aggj(l,4)
3719           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3720           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3721           s1=scalar2(b1(1,iti2),auxvec(1))
3722           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3723           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3724           s2=scalar2(b1(1,iti1),auxvec(1))
3725           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3726           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3727           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3728           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3729           a_temp(1,1)=aggj1(l,1)
3730           a_temp(1,2)=aggj1(l,2)
3731           a_temp(2,1)=aggj1(l,3)
3732           a_temp(2,2)=aggj1(l,4)
3733           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3734           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3735           s1=scalar2(b1(1,iti2),auxvec(1))
3736           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3737           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3738           s2=scalar2(b1(1,iti1),auxvec(1))
3739           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3740           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3741           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3742 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3743           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3744         enddo
3745       return
3746       end
3747 C-----------------------------------------------------------------------------
3748       subroutine vecpr(u,v,w)
3749       implicit real*8(a-h,o-z)
3750       dimension u(3),v(3),w(3)
3751       w(1)=u(2)*v(3)-u(3)*v(2)
3752       w(2)=-u(1)*v(3)+u(3)*v(1)
3753       w(3)=u(1)*v(2)-u(2)*v(1)
3754       return
3755       end
3756 C-----------------------------------------------------------------------------
3757       subroutine unormderiv(u,ugrad,unorm,ungrad)
3758 C This subroutine computes the derivatives of a normalized vector u, given
3759 C the derivatives computed without normalization conditions, ugrad. Returns
3760 C ungrad.
3761       implicit none
3762       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3763       double precision vec(3)
3764       double precision scalar
3765       integer i,j
3766 c      write (2,*) 'ugrad',ugrad
3767 c      write (2,*) 'u',u
3768       do i=1,3
3769         vec(i)=scalar(ugrad(1,i),u(1))
3770       enddo
3771 c      write (2,*) 'vec',vec
3772       do i=1,3
3773         do j=1,3
3774           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3775         enddo
3776       enddo
3777 c      write (2,*) 'ungrad',ungrad
3778       return
3779       end
3780 C-----------------------------------------------------------------------------
3781       subroutine escp_soft_sphere(evdw2,evdw2_14)
3782 C
3783 C This subroutine calculates the excluded-volume interaction energy between
3784 C peptide-group centers and side chains and its gradient in virtual-bond and
3785 C side-chain vectors.
3786 C
3787       implicit real*8 (a-h,o-z)
3788       include 'DIMENSIONS'
3789       include 'COMMON.GEO'
3790       include 'COMMON.VAR'
3791       include 'COMMON.LOCAL'
3792       include 'COMMON.CHAIN'
3793       include 'COMMON.DERIV'
3794       include 'COMMON.INTERACT'
3795       include 'COMMON.FFIELD'
3796       include 'COMMON.IOUNITS'
3797       include 'COMMON.CONTROL'
3798       dimension ggg(3)
3799       evdw2=0.0D0
3800       evdw2_14=0.0d0
3801       r0_scp=4.5d0
3802 cd    print '(a)','Enter ESCP'
3803 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3804       do i=iatscp_s,iatscp_e
3805         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3806         iteli=itel(i)
3807         xi=0.5D0*(c(1,i)+c(1,i+1))
3808         yi=0.5D0*(c(2,i)+c(2,i+1))
3809         zi=0.5D0*(c(3,i)+c(3,i+1))
3810
3811         do iint=1,nscp_gr(i)
3812
3813         do j=iscpstart(i,iint),iscpend(i,iint)
3814           if (itype(j).eq.21) cycle
3815           itypj=itype(j)
3816 C Uncomment following three lines for SC-p interactions
3817 c         xj=c(1,nres+j)-xi
3818 c         yj=c(2,nres+j)-yi
3819 c         zj=c(3,nres+j)-zi
3820 C Uncomment following three lines for Ca-p interactions
3821           xj=c(1,j)-xi
3822           yj=c(2,j)-yi
3823           zj=c(3,j)-zi
3824           rij=xj*xj+yj*yj+zj*zj
3825           r0ij=r0_scp
3826           r0ijsq=r0ij*r0ij
3827           if (rij.lt.r0ijsq) then
3828             evdwij=0.25d0*(rij-r0ijsq)**2
3829             fac=rij-r0ijsq
3830           else
3831             evdwij=0.0d0
3832             fac=0.0d0
3833           endif
3834           evdw2=evdw2+evdwij
3835 C
3836 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3837 C
3838           ggg(1)=xj*fac
3839           ggg(2)=yj*fac
3840           ggg(3)=zj*fac
3841 cgrad          if (j.lt.i) then
3842 cd          write (iout,*) 'j<i'
3843 C Uncomment following three lines for SC-p interactions
3844 c           do k=1,3
3845 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3846 c           enddo
3847 cgrad          else
3848 cd          write (iout,*) 'j>i'
3849 cgrad            do k=1,3
3850 cgrad              ggg(k)=-ggg(k)
3851 C Uncomment following line for SC-p interactions
3852 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3853 cgrad            enddo
3854 cgrad          endif
3855 cgrad          do k=1,3
3856 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3857 cgrad          enddo
3858 cgrad          kstart=min0(i+1,j)
3859 cgrad          kend=max0(i-1,j-1)
3860 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3861 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3862 cgrad          do k=kstart,kend
3863 cgrad            do l=1,3
3864 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3865 cgrad            enddo
3866 cgrad          enddo
3867           do k=1,3
3868             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3869             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3870           enddo
3871         enddo
3872
3873         enddo ! iint
3874       enddo ! i
3875       return
3876       end
3877 C-----------------------------------------------------------------------------
3878       subroutine escp(evdw2,evdw2_14)
3879 C
3880 C This subroutine calculates the excluded-volume interaction energy between
3881 C peptide-group centers and side chains and its gradient in virtual-bond and
3882 C side-chain vectors.
3883 C
3884       implicit real*8 (a-h,o-z)
3885       include 'DIMENSIONS'
3886       include 'COMMON.GEO'
3887       include 'COMMON.VAR'
3888       include 'COMMON.LOCAL'
3889       include 'COMMON.CHAIN'
3890       include 'COMMON.DERIV'
3891       include 'COMMON.INTERACT'
3892       include 'COMMON.FFIELD'
3893       include 'COMMON.IOUNITS'
3894       include 'COMMON.CONTROL'
3895       dimension ggg(3)
3896       evdw2=0.0D0
3897       evdw2_14=0.0d0
3898 cd    print '(a)','Enter ESCP'
3899 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3900       do i=iatscp_s,iatscp_e
3901         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3902         iteli=itel(i)
3903         xi=0.5D0*(c(1,i)+c(1,i+1))
3904         yi=0.5D0*(c(2,i)+c(2,i+1))
3905         zi=0.5D0*(c(3,i)+c(3,i+1))
3906
3907         do iint=1,nscp_gr(i)
3908
3909         do j=iscpstart(i,iint),iscpend(i,iint)
3910           itypj=itype(j)
3911           if (itypj.eq.21) cycle
3912 C Uncomment following three lines for SC-p interactions
3913 c         xj=c(1,nres+j)-xi
3914 c         yj=c(2,nres+j)-yi
3915 c         zj=c(3,nres+j)-zi
3916 C Uncomment following three lines for Ca-p interactions
3917           xj=c(1,j)-xi
3918           yj=c(2,j)-yi
3919           zj=c(3,j)-zi
3920           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3921           fac=rrij**expon2
3922           e1=fac*fac*aad(itypj,iteli)
3923           e2=fac*bad(itypj,iteli)
3924           if (iabs(j-i) .le. 2) then
3925             e1=scal14*e1
3926             e2=scal14*e2
3927             evdw2_14=evdw2_14+e1+e2
3928           endif
3929           evdwij=e1+e2
3930           evdw2=evdw2+evdwij
3931           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3932      &        'evdw2',i,j,evdwij
3933 C
3934 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3935 C
3936           fac=-(evdwij+e1)*rrij
3937           ggg(1)=xj*fac
3938           ggg(2)=yj*fac
3939           ggg(3)=zj*fac
3940 cgrad          if (j.lt.i) then
3941 cd          write (iout,*) 'j<i'
3942 C Uncomment following three lines for SC-p interactions
3943 c           do k=1,3
3944 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3945 c           enddo
3946 cgrad          else
3947 cd          write (iout,*) 'j>i'
3948 cgrad            do k=1,3
3949 cgrad              ggg(k)=-ggg(k)
3950 C Uncomment following line for SC-p interactions
3951 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3952 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3953 cgrad            enddo
3954 cgrad          endif
3955 cgrad          do k=1,3
3956 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3957 cgrad          enddo
3958 cgrad          kstart=min0(i+1,j)
3959 cgrad          kend=max0(i-1,j-1)
3960 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3961 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3962 cgrad          do k=kstart,kend
3963 cgrad            do l=1,3
3964 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3965 cgrad            enddo
3966 cgrad          enddo
3967           do k=1,3
3968             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3969             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3970           enddo
3971         enddo
3972
3973         enddo ! iint
3974       enddo ! i
3975       do i=1,nct
3976         do j=1,3
3977           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3978           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3979           gradx_scp(j,i)=expon*gradx_scp(j,i)
3980         enddo
3981       enddo
3982 C******************************************************************************
3983 C
3984 C                              N O T E !!!
3985 C
3986 C To save time the factor EXPON has been extracted from ALL components
3987 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3988 C use!
3989 C
3990 C******************************************************************************
3991       return
3992       end
3993 C--------------------------------------------------------------------------
3994       subroutine edis(ehpb)
3995 C
3996 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3997 C
3998       implicit real*8 (a-h,o-z)
3999       include 'DIMENSIONS'
4000       include 'COMMON.SBRIDGE'
4001       include 'COMMON.CHAIN'
4002       include 'COMMON.DERIV'
4003       include 'COMMON.VAR'
4004       include 'COMMON.INTERACT'
4005       include 'COMMON.IOUNITS'
4006       dimension ggg(3)
4007       ehpb=0.0D0
4008 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4009 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4010       if (link_end.eq.0) return
4011       do i=link_start,link_end
4012 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4013 C CA-CA distance used in regularization of structure.
4014         ii=ihpb(i)
4015         jj=jhpb(i)
4016 C iii and jjj point to the residues for which the distance is assigned.
4017         if (ii.gt.nres) then
4018           iii=ii-nres
4019           jjj=jj-nres
4020         else
4021           iii=ii
4022           jjj=jj
4023         endif
4024 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4025 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4026 C    distance and angle dependent SS bond potential.
4027         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4028           call ssbond_ene(iii,jjj,eij)
4029           ehpb=ehpb+2*eij
4030 cd          write (iout,*) "eij",eij
4031         else
4032 C Calculate the distance between the two points and its difference from the
4033 C target distance.
4034         dd=dist(ii,jj)
4035         rdis=dd-dhpb(i)
4036 C Get the force constant corresponding to this distance.
4037         waga=forcon(i)
4038 C Calculate the contribution to energy.
4039         ehpb=ehpb+waga*rdis*rdis
4040 C
4041 C Evaluate gradient.
4042 C
4043         fac=waga*rdis/dd
4044 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4045 cd   &   ' waga=',waga,' fac=',fac
4046         do j=1,3
4047           ggg(j)=fac*(c(j,jj)-c(j,ii))
4048         enddo
4049 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4050 C If this is a SC-SC distance, we need to calculate the contributions to the
4051 C Cartesian gradient in the SC vectors (ghpbx).
4052         if (iii.lt.ii) then
4053           do j=1,3
4054             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4055             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4056           enddo
4057         endif
4058 cgrad        do j=iii,jjj-1
4059 cgrad          do k=1,3
4060 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4061 cgrad          enddo
4062 cgrad        enddo
4063         do k=1,3
4064           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4065           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4066         enddo
4067         endif
4068       enddo
4069       ehpb=0.5D0*ehpb
4070       return
4071       end
4072 C--------------------------------------------------------------------------
4073       subroutine ssbond_ene(i,j,eij)
4074 C
4075 C Calculate the distance and angle dependent SS-bond potential energy
4076 C using a free-energy function derived based on RHF/6-31G** ab initio
4077 C calculations of diethyl disulfide.
4078 C
4079 C A. Liwo and U. Kozlowska, 11/24/03
4080 C
4081       implicit real*8 (a-h,o-z)
4082       include 'DIMENSIONS'
4083       include 'COMMON.SBRIDGE'
4084       include 'COMMON.CHAIN'
4085       include 'COMMON.DERIV'
4086       include 'COMMON.LOCAL'
4087       include 'COMMON.INTERACT'
4088       include 'COMMON.VAR'
4089       include 'COMMON.IOUNITS'
4090       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4091       itypi=itype(i)
4092       xi=c(1,nres+i)
4093       yi=c(2,nres+i)
4094       zi=c(3,nres+i)
4095       dxi=dc_norm(1,nres+i)
4096       dyi=dc_norm(2,nres+i)
4097       dzi=dc_norm(3,nres+i)
4098 c      dsci_inv=dsc_inv(itypi)
4099       dsci_inv=vbld_inv(nres+i)
4100       itypj=itype(j)
4101 c      dscj_inv=dsc_inv(itypj)
4102       dscj_inv=vbld_inv(nres+j)
4103       xj=c(1,nres+j)-xi
4104       yj=c(2,nres+j)-yi
4105       zj=c(3,nres+j)-zi
4106       dxj=dc_norm(1,nres+j)
4107       dyj=dc_norm(2,nres+j)
4108       dzj=dc_norm(3,nres+j)
4109       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4110       rij=dsqrt(rrij)
4111       erij(1)=xj*rij
4112       erij(2)=yj*rij
4113       erij(3)=zj*rij
4114       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4115       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4116       om12=dxi*dxj+dyi*dyj+dzi*dzj
4117       do k=1,3
4118         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4119         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4120       enddo
4121       rij=1.0d0/rij
4122       deltad=rij-d0cm
4123       deltat1=1.0d0-om1
4124       deltat2=1.0d0+om2
4125       deltat12=om2-om1+2.0d0
4126       cosphi=om12-om1*om2
4127       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4128      &  +akct*deltad*deltat12
4129      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4130 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4131 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4132 c     &  " deltat12",deltat12," eij",eij
4133       ed=2*akcm*deltad+akct*deltat12
4134       pom1=akct*deltad
4135       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4136       eom1=-2*akth*deltat1-pom1-om2*pom2
4137       eom2= 2*akth*deltat2+pom1-om1*pom2
4138       eom12=pom2
4139       do k=1,3
4140         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4141         ghpbx(k,i)=ghpbx(k,i)-ggk
4142      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4143      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4144         ghpbx(k,j)=ghpbx(k,j)+ggk
4145      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4146      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4147         ghpbc(k,i)=ghpbc(k,i)-ggk
4148         ghpbc(k,j)=ghpbc(k,j)+ggk
4149       enddo
4150 C
4151 C Calculate the components of the gradient in DC and X
4152 C
4153 cgrad      do k=i,j-1
4154 cgrad        do l=1,3
4155 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4156 cgrad        enddo
4157 cgrad      enddo
4158       return
4159       end
4160 C--------------------------------------------------------------------------
4161       subroutine ebond(estr)
4162 c
4163 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4164 c
4165       implicit real*8 (a-h,o-z)
4166       include 'DIMENSIONS'
4167       include 'COMMON.LOCAL'
4168       include 'COMMON.GEO'
4169       include 'COMMON.INTERACT'
4170       include 'COMMON.DERIV'
4171       include 'COMMON.VAR'
4172       include 'COMMON.CHAIN'
4173       include 'COMMON.IOUNITS'
4174       include 'COMMON.NAMES'
4175       include 'COMMON.FFIELD'
4176       include 'COMMON.CONTROL'
4177       include 'COMMON.SETUP'
4178       double precision u(3),ud(3)
4179       estr=0.0d0
4180       estr1=0.0d0
4181       do i=ibondp_start,ibondp_end
4182         if (itype(i-1).eq.21 .or. itype(i).eq.21) then
4183           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4184           do j=1,3
4185           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4186      &      *dc(j,i-1)/vbld(i)
4187           enddo
4188           if (energy_dec) write(iout,*)
4189      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4190         else
4191         diff = vbld(i)-vbldp0
4192         if (energy_dec) write (iout,*)
4193      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4194         estr=estr+diff*diff
4195         do j=1,3
4196           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4197         enddo
4198 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4199         endif
4200       enddo
4201       estr=0.5d0*AKP*estr+estr1
4202 c
4203 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4204 c
4205       do i=ibond_start,ibond_end
4206         iti=itype(i)
4207         if (iti.ne.10 .and. iti.ne.21) then
4208           nbi=nbondterm(iti)
4209           if (nbi.eq.1) then
4210             diff=vbld(i+nres)-vbldsc0(1,iti)
4211             if (energy_dec) write (iout,*)
4212      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4213      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4214             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4215             do j=1,3
4216               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4217             enddo
4218           else
4219             do j=1,nbi
4220               diff=vbld(i+nres)-vbldsc0(j,iti)
4221               ud(j)=aksc(j,iti)*diff
4222               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4223             enddo
4224             uprod=u(1)
4225             do j=2,nbi
4226               uprod=uprod*u(j)
4227             enddo
4228             usum=0.0d0
4229             usumsqder=0.0d0
4230             do j=1,nbi
4231               uprod1=1.0d0
4232               uprod2=1.0d0
4233               do k=1,nbi
4234                 if (k.ne.j) then
4235                   uprod1=uprod1*u(k)
4236                   uprod2=uprod2*u(k)*u(k)
4237                 endif
4238               enddo
4239               usum=usum+uprod1
4240               usumsqder=usumsqder+ud(j)*uprod2
4241             enddo
4242             estr=estr+uprod/usum
4243             do j=1,3
4244              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4245             enddo
4246           endif
4247         endif
4248       enddo
4249       return
4250       end
4251 #ifdef CRYST_THETA
4252 C--------------------------------------------------------------------------
4253       subroutine ebend(etheta)
4254 C
4255 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4256 C angles gamma and its derivatives in consecutive thetas and gammas.
4257 C
4258       implicit real*8 (a-h,o-z)
4259       include 'DIMENSIONS'
4260       include 'COMMON.LOCAL'
4261       include 'COMMON.GEO'
4262       include 'COMMON.INTERACT'
4263       include 'COMMON.DERIV'
4264       include 'COMMON.VAR'
4265       include 'COMMON.CHAIN'
4266       include 'COMMON.IOUNITS'
4267       include 'COMMON.NAMES'
4268       include 'COMMON.FFIELD'
4269       include 'COMMON.CONTROL'
4270       common /calcthet/ term1,term2,termm,diffak,ratak,
4271      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4272      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4273       double precision y(2),z(2)
4274       delta=0.02d0*pi
4275 c      time11=dexp(-2*time)
4276 c      time12=1.0d0
4277       etheta=0.0D0
4278 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4279       do i=ithet_start,ithet_end
4280         if (itype(i-1).eq.21) cycle
4281 C Zero the energy function and its derivative at 0 or pi.
4282         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4283         it=itype(i-1)
4284         if (i.gt.3 .and. itype(i-2).ne.21) then
4285 #ifdef OSF
4286           phii=phi(i)
4287           if (phii.ne.phii) phii=150.0
4288 #else
4289           phii=phi(i)
4290 #endif
4291           y(1)=dcos(phii)
4292           y(2)=dsin(phii)
4293         else
4294           y(1)=0.0D0
4295           y(2)=0.0D0
4296         endif
4297         if (i.lt.nres .and. itype(i).ne.21) then
4298 #ifdef OSF
4299           phii1=phi(i+1)
4300           if (phii1.ne.phii1) phii1=150.0
4301           phii1=pinorm(phii1)
4302           z(1)=cos(phii1)
4303 #else
4304           phii1=phi(i+1)
4305           z(1)=dcos(phii1)
4306 #endif
4307           z(2)=dsin(phii1)
4308         else
4309           z(1)=0.0D0
4310           z(2)=0.0D0
4311         endif
4312 C Calculate the "mean" value of theta from the part of the distribution
4313 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4314 C In following comments this theta will be referred to as t_c.
4315         thet_pred_mean=0.0d0
4316         do k=1,2
4317           athetk=athet(k,it)
4318           bthetk=bthet(k,it)
4319           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4320         enddo
4321         dthett=thet_pred_mean*ssd
4322         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4323 C Derivatives of the "mean" values in gamma1 and gamma2.
4324         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4325         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4326         if (theta(i).gt.pi-delta) then
4327           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4328      &         E_tc0)
4329           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4330           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4331           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4332      &        E_theta)
4333           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4334      &        E_tc)
4335         else if (theta(i).lt.delta) then
4336           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4337           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4338           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4339      &        E_theta)
4340           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4341           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4342      &        E_tc)
4343         else
4344           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4345      &        E_theta,E_tc)
4346         endif
4347         etheta=etheta+ethetai
4348         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4349      &      'ebend',i,ethetai
4350         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4351         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4352         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4353       enddo
4354 C Ufff.... We've done all this!!!
4355       return
4356       end
4357 C---------------------------------------------------------------------------
4358       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4359      &     E_tc)
4360       implicit real*8 (a-h,o-z)
4361       include 'DIMENSIONS'
4362       include 'COMMON.LOCAL'
4363       include 'COMMON.IOUNITS'
4364       common /calcthet/ term1,term2,termm,diffak,ratak,
4365      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4366      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4367 C Calculate the contributions to both Gaussian lobes.
4368 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4369 C The "polynomial part" of the "standard deviation" of this part of
4370 C the distribution.
4371         sig=polthet(3,it)
4372         do j=2,0,-1
4373           sig=sig*thet_pred_mean+polthet(j,it)
4374         enddo
4375 C Derivative of the "interior part" of the "standard deviation of the"
4376 C gamma-dependent Gaussian lobe in t_c.
4377         sigtc=3*polthet(3,it)
4378         do j=2,1,-1
4379           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4380         enddo
4381         sigtc=sig*sigtc
4382 C Set the parameters of both Gaussian lobes of the distribution.
4383 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4384         fac=sig*sig+sigc0(it)
4385         sigcsq=fac+fac
4386         sigc=1.0D0/sigcsq
4387 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4388         sigsqtc=-4.0D0*sigcsq*sigtc
4389 c       print *,i,sig,sigtc,sigsqtc
4390 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4391         sigtc=-sigtc/(fac*fac)
4392 C Following variable is sigma(t_c)**(-2)
4393         sigcsq=sigcsq*sigcsq
4394         sig0i=sig0(it)
4395         sig0inv=1.0D0/sig0i**2
4396         delthec=thetai-thet_pred_mean
4397         delthe0=thetai-theta0i
4398         term1=-0.5D0*sigcsq*delthec*delthec
4399         term2=-0.5D0*sig0inv*delthe0*delthe0
4400 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4401 C NaNs in taking the logarithm. We extract the largest exponent which is added
4402 C to the energy (this being the log of the distribution) at the end of energy
4403 C term evaluation for this virtual-bond angle.
4404         if (term1.gt.term2) then
4405           termm=term1
4406           term2=dexp(term2-termm)
4407           term1=1.0d0
4408         else
4409           termm=term2
4410           term1=dexp(term1-termm)
4411           term2=1.0d0
4412         endif
4413 C The ratio between the gamma-independent and gamma-dependent lobes of
4414 C the distribution is a Gaussian function of thet_pred_mean too.
4415         diffak=gthet(2,it)-thet_pred_mean
4416         ratak=diffak/gthet(3,it)**2
4417         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4418 C Let's differentiate it in thet_pred_mean NOW.
4419         aktc=ak*ratak
4420 C Now put together the distribution terms to make complete distribution.
4421         termexp=term1+ak*term2
4422         termpre=sigc+ak*sig0i
4423 C Contribution of the bending energy from this theta is just the -log of
4424 C the sum of the contributions from the two lobes and the pre-exponential
4425 C factor. Simple enough, isn't it?
4426         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4427 C NOW the derivatives!!!
4428 C 6/6/97 Take into account the deformation.
4429         E_theta=(delthec*sigcsq*term1
4430      &       +ak*delthe0*sig0inv*term2)/termexp
4431         E_tc=((sigtc+aktc*sig0i)/termpre
4432      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4433      &       aktc*term2)/termexp)
4434       return
4435       end
4436 c-----------------------------------------------------------------------------
4437       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4438       implicit real*8 (a-h,o-z)
4439       include 'DIMENSIONS'
4440       include 'COMMON.LOCAL'
4441       include 'COMMON.IOUNITS'
4442       common /calcthet/ term1,term2,termm,diffak,ratak,
4443      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4444      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4445       delthec=thetai-thet_pred_mean
4446       delthe0=thetai-theta0i
4447 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4448       t3 = thetai-thet_pred_mean
4449       t6 = t3**2
4450       t9 = term1
4451       t12 = t3*sigcsq
4452       t14 = t12+t6*sigsqtc
4453       t16 = 1.0d0
4454       t21 = thetai-theta0i
4455       t23 = t21**2
4456       t26 = term2
4457       t27 = t21*t26
4458       t32 = termexp
4459       t40 = t32**2
4460       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4461      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4462      & *(-t12*t9-ak*sig0inv*t27)
4463       return
4464       end
4465 #else
4466 C--------------------------------------------------------------------------
4467       subroutine ebend(etheta)
4468 C
4469 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4470 C angles gamma and its derivatives in consecutive thetas and gammas.
4471 C ab initio-derived potentials from
4472 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4473 C
4474       implicit real*8 (a-h,o-z)
4475       include 'DIMENSIONS'
4476       include 'COMMON.LOCAL'
4477       include 'COMMON.GEO'
4478       include 'COMMON.INTERACT'
4479       include 'COMMON.DERIV'
4480       include 'COMMON.VAR'
4481       include 'COMMON.CHAIN'
4482       include 'COMMON.IOUNITS'
4483       include 'COMMON.NAMES'
4484       include 'COMMON.FFIELD'
4485       include 'COMMON.CONTROL'
4486       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4487      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4488      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4489      & sinph1ph2(maxdouble,maxdouble)
4490       logical lprn /.false./, lprn1 /.false./
4491       etheta=0.0D0
4492       do i=ithet_start,ithet_end
4493         if (itype(i-1).eq.21) cycle
4494         dethetai=0.0d0
4495         dephii=0.0d0
4496         dephii1=0.0d0
4497         theti2=0.5d0*theta(i)
4498         ityp2=ithetyp(itype(i-1))
4499         do k=1,nntheterm
4500           coskt(k)=dcos(k*theti2)
4501           sinkt(k)=dsin(k*theti2)
4502         enddo
4503         if (i.gt.3 .and. itype(i-2).ne.21) then
4504 #ifdef OSF
4505           phii=phi(i)
4506           if (phii.ne.phii) phii=150.0
4507 #else
4508           phii=phi(i)
4509 #endif
4510           ityp1=ithetyp(itype(i-2))
4511           do k=1,nsingle
4512             cosph1(k)=dcos(k*phii)
4513             sinph1(k)=dsin(k*phii)
4514           enddo
4515         else
4516           phii=0.0d0
4517           ityp1=nthetyp+1
4518           do k=1,nsingle
4519             cosph1(k)=0.0d0
4520             sinph1(k)=0.0d0
4521           enddo
4522         endif
4523         if (i.lt.nres .and. itype(i).ne.21) then
4524 #ifdef OSF
4525           phii1=phi(i+1)
4526           if (phii1.ne.phii1) phii1=150.0
4527           phii1=pinorm(phii1)
4528 #else
4529           phii1=phi(i+1)
4530 #endif
4531           ityp3=ithetyp(itype(i))
4532           do k=1,nsingle
4533             cosph2(k)=dcos(k*phii1)
4534             sinph2(k)=dsin(k*phii1)
4535           enddo
4536         else
4537           phii1=0.0d0
4538           ityp3=nthetyp+1
4539           do k=1,nsingle
4540             cosph2(k)=0.0d0
4541             sinph2(k)=0.0d0
4542           enddo
4543         endif
4544         ethetai=aa0thet(ityp1,ityp2,ityp3)
4545         do k=1,ndouble
4546           do l=1,k-1
4547             ccl=cosph1(l)*cosph2(k-l)
4548             ssl=sinph1(l)*sinph2(k-l)
4549             scl=sinph1(l)*cosph2(k-l)
4550             csl=cosph1(l)*sinph2(k-l)
4551             cosph1ph2(l,k)=ccl-ssl
4552             cosph1ph2(k,l)=ccl+ssl
4553             sinph1ph2(l,k)=scl+csl
4554             sinph1ph2(k,l)=scl-csl
4555           enddo
4556         enddo
4557         if (lprn) then
4558         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4559      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4560         write (iout,*) "coskt and sinkt"
4561         do k=1,nntheterm
4562           write (iout,*) k,coskt(k),sinkt(k)
4563         enddo
4564         endif
4565         do k=1,ntheterm
4566           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4567           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4568      &      *coskt(k)
4569           if (lprn)
4570      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4571      &     " ethetai",ethetai
4572         enddo
4573         if (lprn) then
4574         write (iout,*) "cosph and sinph"
4575         do k=1,nsingle
4576           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4577         enddo
4578         write (iout,*) "cosph1ph2 and sinph2ph2"
4579         do k=2,ndouble
4580           do l=1,k-1
4581             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4582      &         sinph1ph2(l,k),sinph1ph2(k,l)
4583           enddo
4584         enddo
4585         write(iout,*) "ethetai",ethetai
4586         endif
4587         do m=1,ntheterm2
4588           do k=1,nsingle
4589             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4590      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4591      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4592      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4593             ethetai=ethetai+sinkt(m)*aux
4594             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4595             dephii=dephii+k*sinkt(m)*(
4596      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4597      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4598             dephii1=dephii1+k*sinkt(m)*(
4599      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4600      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4601             if (lprn)
4602      &      write (iout,*) "m",m," k",k," bbthet",
4603      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4604      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4605      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4606      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4607           enddo
4608         enddo
4609         if (lprn)
4610      &  write(iout,*) "ethetai",ethetai
4611         do m=1,ntheterm3
4612           do k=2,ndouble
4613             do l=1,k-1
4614               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4615      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4616      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4617      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4618               ethetai=ethetai+sinkt(m)*aux
4619               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4620               dephii=dephii+l*sinkt(m)*(
4621      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4622      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4623      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4624      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4625               dephii1=dephii1+(k-l)*sinkt(m)*(
4626      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4627      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4628      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4629      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4630               if (lprn) then
4631               write (iout,*) "m",m," k",k," l",l," ffthet",
4632      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4633      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4634      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4635      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4636               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4637      &            cosph1ph2(k,l)*sinkt(m),
4638      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4639               endif
4640             enddo
4641           enddo
4642         enddo
4643 10      continue
4644         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4645      &   i,theta(i)*rad2deg,phii*rad2deg,
4646      &   phii1*rad2deg,ethetai
4647         etheta=etheta+ethetai
4648         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4649         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4650         gloc(nphi+i-2,icg)=wang*dethetai
4651       enddo
4652       return
4653       end
4654 #endif
4655 #ifdef CRYST_SC
4656 c-----------------------------------------------------------------------------
4657       subroutine esc(escloc)
4658 C Calculate the local energy of a side chain and its derivatives in the
4659 C corresponding virtual-bond valence angles THETA and the spherical angles
4660 C ALPHA and OMEGA.
4661       implicit real*8 (a-h,o-z)
4662       include 'DIMENSIONS'
4663       include 'COMMON.GEO'
4664       include 'COMMON.LOCAL'
4665       include 'COMMON.VAR'
4666       include 'COMMON.INTERACT'
4667       include 'COMMON.DERIV'
4668       include 'COMMON.CHAIN'
4669       include 'COMMON.IOUNITS'
4670       include 'COMMON.NAMES'
4671       include 'COMMON.FFIELD'
4672       include 'COMMON.CONTROL'
4673       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4674      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4675       common /sccalc/ time11,time12,time112,theti,it,nlobit
4676       delta=0.02d0*pi
4677       escloc=0.0D0
4678 c     write (iout,'(a)') 'ESC'
4679       do i=loc_start,loc_end
4680         it=itype(i)
4681         if (it.eq.21) cycle
4682         if (it.eq.10) goto 1
4683         nlobit=nlob(it)
4684 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4685 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4686         theti=theta(i+1)-pipol
4687         x(1)=dtan(theti)
4688         x(2)=alph(i)
4689         x(3)=omeg(i)
4690
4691         if (x(2).gt.pi-delta) then
4692           xtemp(1)=x(1)
4693           xtemp(2)=pi-delta
4694           xtemp(3)=x(3)
4695           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4696           xtemp(2)=pi
4697           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4698           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4699      &        escloci,dersc(2))
4700           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4701      &        ddersc0(1),dersc(1))
4702           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4703      &        ddersc0(3),dersc(3))
4704           xtemp(2)=pi-delta
4705           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4706           xtemp(2)=pi
4707           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4708           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4709      &            dersc0(2),esclocbi,dersc02)
4710           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4711      &            dersc12,dersc01)
4712           call splinthet(x(2),0.5d0*delta,ss,ssd)
4713           dersc0(1)=dersc01
4714           dersc0(2)=dersc02
4715           dersc0(3)=0.0d0
4716           do k=1,3
4717             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4718           enddo
4719           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4720 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4721 c    &             esclocbi,ss,ssd
4722           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4723 c         escloci=esclocbi
4724 c         write (iout,*) escloci
4725         else if (x(2).lt.delta) then
4726           xtemp(1)=x(1)
4727           xtemp(2)=delta
4728           xtemp(3)=x(3)
4729           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4730           xtemp(2)=0.0d0
4731           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4732           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4733      &        escloci,dersc(2))
4734           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4735      &        ddersc0(1),dersc(1))
4736           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4737      &        ddersc0(3),dersc(3))
4738           xtemp(2)=delta
4739           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4740           xtemp(2)=0.0d0
4741           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4742           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4743      &            dersc0(2),esclocbi,dersc02)
4744           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4745      &            dersc12,dersc01)
4746           dersc0(1)=dersc01
4747           dersc0(2)=dersc02
4748           dersc0(3)=0.0d0
4749           call splinthet(x(2),0.5d0*delta,ss,ssd)
4750           do k=1,3
4751             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4752           enddo
4753           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4754 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4755 c    &             esclocbi,ss,ssd
4756           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4757 c         write (iout,*) escloci
4758         else
4759           call enesc(x,escloci,dersc,ddummy,.false.)
4760         endif
4761
4762         escloc=escloc+escloci
4763         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4764      &     'escloc',i,escloci
4765 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4766
4767         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4768      &   wscloc*dersc(1)
4769         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4770         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4771     1   continue
4772       enddo
4773       return
4774       end
4775 C---------------------------------------------------------------------------
4776       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4777       implicit real*8 (a-h,o-z)
4778       include 'DIMENSIONS'
4779       include 'COMMON.GEO'
4780       include 'COMMON.LOCAL'
4781       include 'COMMON.IOUNITS'
4782       common /sccalc/ time11,time12,time112,theti,it,nlobit
4783       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4784       double precision contr(maxlob,-1:1)
4785       logical mixed
4786 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4787         escloc_i=0.0D0
4788         do j=1,3
4789           dersc(j)=0.0D0
4790           if (mixed) ddersc(j)=0.0d0
4791         enddo
4792         x3=x(3)
4793
4794 C Because of periodicity of the dependence of the SC energy in omega we have
4795 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4796 C To avoid underflows, first compute & store the exponents.
4797
4798         do iii=-1,1
4799
4800           x(3)=x3+iii*dwapi
4801
4802           do j=1,nlobit
4803             do k=1,3
4804               z(k)=x(k)-censc(k,j,it)
4805             enddo
4806             do k=1,3
4807               Axk=0.0D0
4808               do l=1,3
4809                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4810               enddo
4811               Ax(k,j,iii)=Axk
4812             enddo
4813             expfac=0.0D0
4814             do k=1,3
4815               expfac=expfac+Ax(k,j,iii)*z(k)
4816             enddo
4817             contr(j,iii)=expfac
4818           enddo ! j
4819
4820         enddo ! iii
4821
4822         x(3)=x3
4823 C As in the case of ebend, we want to avoid underflows in exponentiation and
4824 C subsequent NaNs and INFs in energy calculation.
4825 C Find the largest exponent
4826         emin=contr(1,-1)
4827         do iii=-1,1
4828           do j=1,nlobit
4829             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4830           enddo
4831         enddo
4832         emin=0.5D0*emin
4833 cd      print *,'it=',it,' emin=',emin
4834
4835 C Compute the contribution to SC energy and derivatives
4836         do iii=-1,1
4837
4838           do j=1,nlobit
4839 #ifdef OSF
4840             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4841             if(adexp.ne.adexp) adexp=1.0
4842             expfac=dexp(adexp)
4843 #else
4844             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4845 #endif
4846 cd          print *,'j=',j,' expfac=',expfac
4847             escloc_i=escloc_i+expfac
4848             do k=1,3
4849               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4850             enddo
4851             if (mixed) then
4852               do k=1,3,2
4853                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4854      &            +gaussc(k,2,j,it))*expfac
4855               enddo
4856             endif
4857           enddo
4858
4859         enddo ! iii
4860
4861         dersc(1)=dersc(1)/cos(theti)**2
4862         ddersc(1)=ddersc(1)/cos(theti)**2
4863         ddersc(3)=ddersc(3)
4864
4865         escloci=-(dlog(escloc_i)-emin)
4866         do j=1,3
4867           dersc(j)=dersc(j)/escloc_i
4868         enddo
4869         if (mixed) then
4870           do j=1,3,2
4871             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4872           enddo
4873         endif
4874       return
4875       end
4876 C------------------------------------------------------------------------------
4877       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4878       implicit real*8 (a-h,o-z)
4879       include 'DIMENSIONS'
4880       include 'COMMON.GEO'
4881       include 'COMMON.LOCAL'
4882       include 'COMMON.IOUNITS'
4883       common /sccalc/ time11,time12,time112,theti,it,nlobit
4884       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4885       double precision contr(maxlob)
4886       logical mixed
4887
4888       escloc_i=0.0D0
4889
4890       do j=1,3
4891         dersc(j)=0.0D0
4892       enddo
4893
4894       do j=1,nlobit
4895         do k=1,2
4896           z(k)=x(k)-censc(k,j,it)
4897         enddo
4898         z(3)=dwapi
4899         do k=1,3
4900           Axk=0.0D0
4901           do l=1,3
4902             Axk=Axk+gaussc(l,k,j,it)*z(l)
4903           enddo
4904           Ax(k,j)=Axk
4905         enddo
4906         expfac=0.0D0
4907         do k=1,3
4908           expfac=expfac+Ax(k,j)*z(k)
4909         enddo
4910         contr(j)=expfac
4911       enddo ! j
4912
4913 C As in the case of ebend, we want to avoid underflows in exponentiation and
4914 C subsequent NaNs and INFs in energy calculation.
4915 C Find the largest exponent
4916       emin=contr(1)
4917       do j=1,nlobit
4918         if (emin.gt.contr(j)) emin=contr(j)
4919       enddo
4920       emin=0.5D0*emin
4921
4922 C Compute the contribution to SC energy and derivatives
4923
4924       dersc12=0.0d0
4925       do j=1,nlobit
4926         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4927         escloc_i=escloc_i+expfac
4928         do k=1,2
4929           dersc(k)=dersc(k)+Ax(k,j)*expfac
4930         enddo
4931         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4932      &            +gaussc(1,2,j,it))*expfac
4933         dersc(3)=0.0d0
4934       enddo
4935
4936       dersc(1)=dersc(1)/cos(theti)**2
4937       dersc12=dersc12/cos(theti)**2
4938       escloci=-(dlog(escloc_i)-emin)
4939       do j=1,2
4940         dersc(j)=dersc(j)/escloc_i
4941       enddo
4942       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4943       return
4944       end
4945 #else
4946 c----------------------------------------------------------------------------------
4947       subroutine esc(escloc)
4948 C Calculate the local energy of a side chain and its derivatives in the
4949 C corresponding virtual-bond valence angles THETA and the spherical angles
4950 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4951 C added by Urszula Kozlowska. 07/11/2007
4952 C
4953       implicit real*8 (a-h,o-z)
4954       include 'DIMENSIONS'
4955       include 'COMMON.GEO'
4956       include 'COMMON.LOCAL'
4957       include 'COMMON.VAR'
4958       include 'COMMON.SCROT'
4959       include 'COMMON.INTERACT'
4960       include 'COMMON.DERIV'
4961       include 'COMMON.CHAIN'
4962       include 'COMMON.IOUNITS'
4963       include 'COMMON.NAMES'
4964       include 'COMMON.FFIELD'
4965       include 'COMMON.CONTROL'
4966       include 'COMMON.VECTORS'
4967       double precision x_prime(3),y_prime(3),z_prime(3)
4968      &    , sumene,dsc_i,dp2_i,x(65),
4969      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4970      &    de_dxx,de_dyy,de_dzz,de_dt
4971       double precision s1_t,s1_6_t,s2_t,s2_6_t
4972       double precision
4973      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4974      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4975      & dt_dCi(3),dt_dCi1(3)
4976       common /sccalc/ time11,time12,time112,theti,it,nlobit
4977       delta=0.02d0*pi
4978       escloc=0.0D0
4979       do i=loc_start,loc_end
4980         if (itype(i).eq.21) cycle
4981         costtab(i+1) =dcos(theta(i+1))
4982         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4983         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4984         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4985         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4986         cosfac=dsqrt(cosfac2)
4987         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4988         sinfac=dsqrt(sinfac2)
4989         it=itype(i)
4990         if (it.eq.10) goto 1
4991 c
4992 C  Compute the axes of tghe local cartesian coordinates system; store in
4993 c   x_prime, y_prime and z_prime
4994 c
4995         do j=1,3
4996           x_prime(j) = 0.00
4997           y_prime(j) = 0.00
4998           z_prime(j) = 0.00
4999         enddo
5000 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5001 C     &   dc_norm(3,i+nres)
5002         do j = 1,3
5003           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5004           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5005         enddo
5006         do j = 1,3
5007           z_prime(j) = -uz(j,i-1)
5008         enddo
5009 c       write (2,*) "i",i
5010 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5011 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5012 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5013 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5014 c      & " xy",scalar(x_prime(1),y_prime(1)),
5015 c      & " xz",scalar(x_prime(1),z_prime(1)),
5016 c      & " yy",scalar(y_prime(1),y_prime(1)),
5017 c      & " yz",scalar(y_prime(1),z_prime(1)),
5018 c      & " zz",scalar(z_prime(1),z_prime(1))
5019 c
5020 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5021 C to local coordinate system. Store in xx, yy, zz.
5022 c
5023         xx=0.0d0
5024         yy=0.0d0
5025         zz=0.0d0
5026         do j = 1,3
5027           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5028           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5029           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5030         enddo
5031
5032         xxtab(i)=xx
5033         yytab(i)=yy
5034         zztab(i)=zz
5035 C
5036 C Compute the energy of the ith side cbain
5037 C
5038 c        write (2,*) "xx",xx," yy",yy," zz",zz
5039         it=itype(i)
5040         do j = 1,65
5041           x(j) = sc_parmin(j,it)
5042         enddo
5043 #ifdef CHECK_COORD
5044 Cc diagnostics - remove later
5045         xx1 = dcos(alph(2))
5046         yy1 = dsin(alph(2))*dcos(omeg(2))
5047         zz1 = -dsin(alph(2))*dsin(omeg(2))
5048         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5049      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5050      &    xx1,yy1,zz1
5051 C,"  --- ", xx_w,yy_w,zz_w
5052 c end diagnostics
5053 #endif
5054         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5055      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5056      &   + x(10)*yy*zz
5057         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5058      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5059      & + x(20)*yy*zz
5060         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5061      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5062      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5063      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5064      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5065      &  +x(40)*xx*yy*zz
5066         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5067      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5068      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5069      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5070      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5071      &  +x(60)*xx*yy*zz
5072         dsc_i   = 0.743d0+x(61)
5073         dp2_i   = 1.9d0+x(62)
5074         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5075      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5076         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5077      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5078         s1=(1+x(63))/(0.1d0 + dscp1)
5079         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5080         s2=(1+x(65))/(0.1d0 + dscp2)
5081         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5082         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5083      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5084 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5085 c     &   sumene4,
5086 c     &   dscp1,dscp2,sumene
5087 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5088         escloc = escloc + sumene
5089 c        write (2,*) "i",i," escloc",sumene,escloc
5090 #ifdef DEBUG
5091 C
5092 C This section to check the numerical derivatives of the energy of ith side
5093 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5094 C #define DEBUG in the code to turn it on.
5095 C
5096         write (2,*) "sumene               =",sumene
5097         aincr=1.0d-7
5098         xxsave=xx
5099         xx=xx+aincr
5100         write (2,*) xx,yy,zz
5101         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5102         de_dxx_num=(sumenep-sumene)/aincr
5103         xx=xxsave
5104         write (2,*) "xx+ sumene from enesc=",sumenep
5105         yysave=yy
5106         yy=yy+aincr
5107         write (2,*) xx,yy,zz
5108         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5109         de_dyy_num=(sumenep-sumene)/aincr
5110         yy=yysave
5111         write (2,*) "yy+ sumene from enesc=",sumenep
5112         zzsave=zz
5113         zz=zz+aincr
5114         write (2,*) xx,yy,zz
5115         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5116         de_dzz_num=(sumenep-sumene)/aincr
5117         zz=zzsave
5118         write (2,*) "zz+ sumene from enesc=",sumenep
5119         costsave=cost2tab(i+1)
5120         sintsave=sint2tab(i+1)
5121         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5122         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5123         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5124         de_dt_num=(sumenep-sumene)/aincr
5125         write (2,*) " t+ sumene from enesc=",sumenep
5126         cost2tab(i+1)=costsave
5127         sint2tab(i+1)=sintsave
5128 C End of diagnostics section.
5129 #endif
5130 C
5131 C Compute the gradient of esc
5132 C
5133         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5134         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5135         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5136         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5137         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5138         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5139         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5140         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5141         pom1=(sumene3*sint2tab(i+1)+sumene1)
5142      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5143         pom2=(sumene4*cost2tab(i+1)+sumene2)
5144      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5145         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5146         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5147      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5148      &  +x(40)*yy*zz
5149         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5150         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5151      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5152      &  +x(60)*yy*zz
5153         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5154      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5155      &        +(pom1+pom2)*pom_dx
5156 #ifdef DEBUG
5157         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5158 #endif
5159 C
5160         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5161         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5162      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5163      &  +x(40)*xx*zz
5164         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5165         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5166      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5167      &  +x(59)*zz**2 +x(60)*xx*zz
5168         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5169      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5170      &        +(pom1-pom2)*pom_dy
5171 #ifdef DEBUG
5172         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5173 #endif
5174 C
5175         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5176      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5177      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5178      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5179      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5180      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5181      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5182      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5183 #ifdef DEBUG
5184         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5185 #endif
5186 C
5187         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5188      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5189      &  +pom1*pom_dt1+pom2*pom_dt2
5190 #ifdef DEBUG
5191         write(2,*), "de_dt = ", de_dt,de_dt_num
5192 #endif
5193 c
5194 C
5195        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5196        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5197        cosfac2xx=cosfac2*xx
5198        sinfac2yy=sinfac2*yy
5199        do k = 1,3
5200          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5201      &      vbld_inv(i+1)
5202          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5203      &      vbld_inv(i)
5204          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5205          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5206 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5207 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5208 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5209 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5210          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5211          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5212          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5213          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5214          dZZ_Ci1(k)=0.0d0
5215          dZZ_Ci(k)=0.0d0
5216          do j=1,3
5217            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5218            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5219          enddo
5220
5221          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5222          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5223          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5224 c
5225          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5226          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5227        enddo
5228
5229        do k=1,3
5230          dXX_Ctab(k,i)=dXX_Ci(k)
5231          dXX_C1tab(k,i)=dXX_Ci1(k)
5232          dYY_Ctab(k,i)=dYY_Ci(k)
5233          dYY_C1tab(k,i)=dYY_Ci1(k)
5234          dZZ_Ctab(k,i)=dZZ_Ci(k)
5235          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5236          dXX_XYZtab(k,i)=dXX_XYZ(k)
5237          dYY_XYZtab(k,i)=dYY_XYZ(k)
5238          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5239        enddo
5240
5241        do k = 1,3
5242 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5243 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5244 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5245 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5246 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5247 c     &    dt_dci(k)
5248 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5249 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5250          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5251      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5252          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5253      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5254          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5255      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5256        enddo
5257 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5258 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5259
5260 C to check gradient call subroutine check_grad
5261
5262     1 continue
5263       enddo
5264       return
5265       end
5266 c------------------------------------------------------------------------------
5267       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5268       implicit none
5269       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5270      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5271       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5272      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5273      &   + x(10)*yy*zz
5274       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5275      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5276      & + x(20)*yy*zz
5277       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5278      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5279      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5280      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5281      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5282      &  +x(40)*xx*yy*zz
5283       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5284      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5285      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5286      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5287      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5288      &  +x(60)*xx*yy*zz
5289       dsc_i   = 0.743d0+x(61)
5290       dp2_i   = 1.9d0+x(62)
5291       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5292      &          *(xx*cost2+yy*sint2))
5293       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5294      &          *(xx*cost2-yy*sint2))
5295       s1=(1+x(63))/(0.1d0 + dscp1)
5296       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5297       s2=(1+x(65))/(0.1d0 + dscp2)
5298       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5299       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5300      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5301       enesc=sumene
5302       return
5303       end
5304 #endif
5305 c------------------------------------------------------------------------------
5306       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5307 C
5308 C This procedure calculates two-body contact function g(rij) and its derivative:
5309 C
5310 C           eps0ij                                     !       x < -1
5311 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5312 C            0                                         !       x > 1
5313 C
5314 C where x=(rij-r0ij)/delta
5315 C
5316 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5317 C
5318       implicit none
5319       double precision rij,r0ij,eps0ij,fcont,fprimcont
5320       double precision x,x2,x4,delta
5321 c     delta=0.02D0*r0ij
5322 c      delta=0.2D0*r0ij
5323       x=(rij-r0ij)/delta
5324       if (x.lt.-1.0D0) then
5325         fcont=eps0ij
5326         fprimcont=0.0D0
5327       else if (x.le.1.0D0) then
5328         x2=x*x
5329         x4=x2*x2
5330         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5331         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5332       else
5333         fcont=0.0D0
5334         fprimcont=0.0D0
5335       endif
5336       return
5337       end
5338 c------------------------------------------------------------------------------
5339       subroutine splinthet(theti,delta,ss,ssder)
5340       implicit real*8 (a-h,o-z)
5341       include 'DIMENSIONS'
5342       include 'COMMON.VAR'
5343       include 'COMMON.GEO'
5344       thetup=pi-delta
5345       thetlow=delta
5346       if (theti.gt.pipol) then
5347         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5348       else
5349         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5350         ssder=-ssder
5351       endif
5352       return
5353       end
5354 c------------------------------------------------------------------------------
5355       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5356       implicit none
5357       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5358       double precision ksi,ksi2,ksi3,a1,a2,a3
5359       a1=fprim0*delta/(f1-f0)
5360       a2=3.0d0-2.0d0*a1
5361       a3=a1-2.0d0
5362       ksi=(x-x0)/delta
5363       ksi2=ksi*ksi
5364       ksi3=ksi2*ksi
5365       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5366       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5367       return
5368       end
5369 c------------------------------------------------------------------------------
5370       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5371       implicit none
5372       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5373       double precision ksi,ksi2,ksi3,a1,a2,a3
5374       ksi=(x-x0)/delta
5375       ksi2=ksi*ksi
5376       ksi3=ksi2*ksi
5377       a1=fprim0x*delta
5378       a2=3*(f1x-f0x)-2*fprim0x*delta
5379       a3=fprim0x*delta-2*(f1x-f0x)
5380       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5381       return
5382       end
5383 C-----------------------------------------------------------------------------
5384 #ifdef CRYST_TOR
5385 C-----------------------------------------------------------------------------
5386       subroutine etor(etors,edihcnstr)
5387       implicit real*8 (a-h,o-z)
5388       include 'DIMENSIONS'
5389       include 'COMMON.VAR'
5390       include 'COMMON.GEO'
5391       include 'COMMON.LOCAL'
5392       include 'COMMON.TORSION'
5393       include 'COMMON.INTERACT'
5394       include 'COMMON.DERIV'
5395       include 'COMMON.CHAIN'
5396       include 'COMMON.NAMES'
5397       include 'COMMON.IOUNITS'
5398       include 'COMMON.FFIELD'
5399       include 'COMMON.TORCNSTR'
5400       include 'COMMON.CONTROL'
5401       logical lprn
5402 C Set lprn=.true. for debugging
5403       lprn=.false.
5404 c      lprn=.true.
5405       etors=0.0D0
5406       do i=iphi_start,iphi_end
5407       etors_ii=0.0D0
5408         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5409      &      .or. itype(i).eq.21) cycle
5410         itori=itortyp(itype(i-2))
5411         itori1=itortyp(itype(i-1))
5412         phii=phi(i)
5413         gloci=0.0D0
5414 C Proline-Proline pair is a special case...
5415         if (itori.eq.3 .and. itori1.eq.3) then
5416           if (phii.gt.-dwapi3) then
5417             cosphi=dcos(3*phii)
5418             fac=1.0D0/(1.0D0-cosphi)
5419             etorsi=v1(1,3,3)*fac
5420             etorsi=etorsi+etorsi
5421             etors=etors+etorsi-v1(1,3,3)
5422             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5423             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5424           endif
5425           do j=1,3
5426             v1ij=v1(j+1,itori,itori1)
5427             v2ij=v2(j+1,itori,itori1)
5428             cosphi=dcos(j*phii)
5429             sinphi=dsin(j*phii)
5430             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5431             if (energy_dec) etors_ii=etors_ii+
5432      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5433             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5434           enddo
5435         else
5436           do j=1,nterm_old
5437             v1ij=v1(j,itori,itori1)
5438             v2ij=v2(j,itori,itori1)
5439             cosphi=dcos(j*phii)
5440             sinphi=dsin(j*phii)
5441             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5442             if (energy_dec) etors_ii=etors_ii+
5443      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5444             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5445           enddo
5446         endif
5447         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5448              'etor',i,etors_ii
5449         if (lprn)
5450      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5451      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5452      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5453         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5454 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5455       enddo
5456 ! 6/20/98 - dihedral angle constraints
5457       edihcnstr=0.0d0
5458       do i=1,ndih_constr
5459         itori=idih_constr(i)
5460         phii=phi(itori)
5461         difi=phii-phi0(i)
5462         if (difi.gt.drange(i)) then
5463           difi=difi-drange(i)
5464           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5465           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5466         else if (difi.lt.-drange(i)) then
5467           difi=difi+drange(i)
5468           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5469           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5470         endif
5471 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5472 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5473       enddo
5474 !      write (iout,*) 'edihcnstr',edihcnstr
5475       return
5476       end
5477 c------------------------------------------------------------------------------
5478       subroutine etor_d(etors_d)
5479       etors_d=0.0d0
5480       return
5481       end
5482 c----------------------------------------------------------------------------
5483 #else
5484       subroutine etor(etors,edihcnstr)
5485       implicit real*8 (a-h,o-z)
5486       include 'DIMENSIONS'
5487       include 'COMMON.VAR'
5488       include 'COMMON.GEO'
5489       include 'COMMON.LOCAL'
5490       include 'COMMON.TORSION'
5491       include 'COMMON.INTERACT'
5492       include 'COMMON.DERIV'
5493       include 'COMMON.CHAIN'
5494       include 'COMMON.NAMES'
5495       include 'COMMON.IOUNITS'
5496       include 'COMMON.FFIELD'
5497       include 'COMMON.TORCNSTR'
5498       include 'COMMON.CONTROL'
5499       logical lprn
5500 C Set lprn=.true. for debugging
5501       lprn=.false.
5502 c     lprn=.true.
5503       etors=0.0D0
5504       do i=iphi_start,iphi_end
5505         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5506      &       .or. itype(i).eq.21) cycle
5507         etors_ii=0.0D0
5508         itori=itortyp(itype(i-2))
5509         itori1=itortyp(itype(i-1))
5510         phii=phi(i)
5511         gloci=0.0D0
5512 C Regular cosine and sine terms
5513         do j=1,nterm(itori,itori1)
5514           v1ij=v1(j,itori,itori1)
5515           v2ij=v2(j,itori,itori1)
5516           cosphi=dcos(j*phii)
5517           sinphi=dsin(j*phii)
5518           etors=etors+v1ij*cosphi+v2ij*sinphi
5519           if (energy_dec) etors_ii=etors_ii+
5520      &                v1ij*cosphi+v2ij*sinphi
5521           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5522         enddo
5523 C Lorentz terms
5524 C                         v1
5525 C  E = SUM ----------------------------------- - v1
5526 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5527 C
5528         cosphi=dcos(0.5d0*phii)
5529         sinphi=dsin(0.5d0*phii)
5530         do j=1,nlor(itori,itori1)
5531           vl1ij=vlor1(j,itori,itori1)
5532           vl2ij=vlor2(j,itori,itori1)
5533           vl3ij=vlor3(j,itori,itori1)
5534           pom=vl2ij*cosphi+vl3ij*sinphi
5535           pom1=1.0d0/(pom*pom+1.0d0)
5536           etors=etors+vl1ij*pom1
5537           if (energy_dec) etors_ii=etors_ii+
5538      &                vl1ij*pom1
5539           pom=-pom*pom1*pom1
5540           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5541         enddo
5542 C Subtract the constant term
5543         etors=etors-v0(itori,itori1)
5544           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5545      &         'etor',i,etors_ii-v0(itori,itori1)
5546         if (lprn)
5547      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5548      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5549      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5550         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5551 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5552       enddo
5553 ! 6/20/98 - dihedral angle constraints
5554       edihcnstr=0.0d0
5555 c      do i=1,ndih_constr
5556       do i=idihconstr_start,idihconstr_end
5557         itori=idih_constr(i)
5558         phii=phi(itori)
5559         difi=pinorm(phii-phi0(i))
5560         if (difi.gt.drange(i)) then
5561           difi=difi-drange(i)
5562           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5563           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5564         else if (difi.lt.-drange(i)) then
5565           difi=difi+drange(i)
5566           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5567           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5568         else
5569           difi=0.0
5570         endif
5571 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5572 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5573 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5574       enddo
5575 cd       write (iout,*) 'edihcnstr',edihcnstr
5576       return
5577       end
5578 c----------------------------------------------------------------------------
5579       subroutine etor_d(etors_d)
5580 C 6/23/01 Compute double torsional energy
5581       implicit real*8 (a-h,o-z)
5582       include 'DIMENSIONS'
5583       include 'COMMON.VAR'
5584       include 'COMMON.GEO'
5585       include 'COMMON.LOCAL'
5586       include 'COMMON.TORSION'
5587       include 'COMMON.INTERACT'
5588       include 'COMMON.DERIV'
5589       include 'COMMON.CHAIN'
5590       include 'COMMON.NAMES'
5591       include 'COMMON.IOUNITS'
5592       include 'COMMON.FFIELD'
5593       include 'COMMON.TORCNSTR'
5594       logical lprn
5595 C Set lprn=.true. for debugging
5596       lprn=.false.
5597 c     lprn=.true.
5598       etors_d=0.0D0
5599       do i=iphid_start,iphid_end
5600         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5601      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle
5602         itori=itortyp(itype(i-2))
5603         itori1=itortyp(itype(i-1))
5604         itori2=itortyp(itype(i))
5605         phii=phi(i)
5606         phii1=phi(i+1)
5607         gloci1=0.0D0
5608         gloci2=0.0D0
5609 C Regular cosine and sine terms
5610         do j=1,ntermd_1(itori,itori1,itori2)
5611           v1cij=v1c(1,j,itori,itori1,itori2)
5612           v1sij=v1s(1,j,itori,itori1,itori2)
5613           v2cij=v1c(2,j,itori,itori1,itori2)
5614           v2sij=v1s(2,j,itori,itori1,itori2)
5615           cosphi1=dcos(j*phii)
5616           sinphi1=dsin(j*phii)
5617           cosphi2=dcos(j*phii1)
5618           sinphi2=dsin(j*phii1)
5619           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5620      &     v2cij*cosphi2+v2sij*sinphi2
5621           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5622           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5623         enddo
5624         do k=2,ntermd_2(itori,itori1,itori2)
5625           do l=1,k-1
5626             v1cdij = v2c(k,l,itori,itori1,itori2)
5627             v2cdij = v2c(l,k,itori,itori1,itori2)
5628             v1sdij = v2s(k,l,itori,itori1,itori2)
5629             v2sdij = v2s(l,k,itori,itori1,itori2)
5630             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5631             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5632             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5633             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5634             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5635      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5636             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5637      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5638             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5639      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5640           enddo
5641         enddo
5642         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5643         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5644       enddo
5645       return
5646       end
5647 #endif
5648 c------------------------------------------------------------------------------
5649       subroutine eback_sc_corr(esccor)
5650 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5651 c        conformational states; temporarily implemented as differences
5652 c        between UNRES torsional potentials (dependent on three types of
5653 c        residues) and the torsional potentials dependent on all 20 types
5654 c        of residues computed from AM1  energy surfaces of terminally-blocked
5655 c        amino-acid residues.
5656       implicit real*8 (a-h,o-z)
5657       include 'DIMENSIONS'
5658       include 'COMMON.VAR'
5659       include 'COMMON.GEO'
5660       include 'COMMON.LOCAL'
5661       include 'COMMON.TORSION'
5662       include 'COMMON.SCCOR'
5663       include 'COMMON.INTERACT'
5664       include 'COMMON.DERIV'
5665       include 'COMMON.CHAIN'
5666       include 'COMMON.NAMES'
5667       include 'COMMON.IOUNITS'
5668       include 'COMMON.FFIELD'
5669       include 'COMMON.CONTROL'
5670       logical lprn
5671 C Set lprn=.true. for debugging
5672       lprn=.false.
5673 c      lprn=.true.
5674 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5675       esccor=0.0D0
5676       do i=iphi_start,iphi_end
5677         if (itype(i-2).eq.21 .or. itype(i-1).eq.21) cycle
5678         esccor_ii=0.0D0
5679         itori=itype(i-2)
5680         itori1=itype(i-1)
5681         phii=phi(i)
5682         gloci=0.0D0
5683         do j=1,nterm_sccor
5684           v1ij=v1sccor(j,itori,itori1)
5685           v2ij=v2sccor(j,itori,itori1)
5686           cosphi=dcos(j*phii)
5687           sinphi=dsin(j*phii)
5688           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5689           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5690         enddo
5691         if (lprn)
5692      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5693      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5694      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5695         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5696       enddo
5697       return
5698       end
5699 c----------------------------------------------------------------------------
5700       subroutine multibody(ecorr)
5701 C This subroutine calculates multi-body contributions to energy following
5702 C the idea of Skolnick et al. If side chains I and J make a contact and
5703 C at the same time side chains I+1 and J+1 make a contact, an extra
5704 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5705       implicit real*8 (a-h,o-z)
5706       include 'DIMENSIONS'
5707       include 'COMMON.IOUNITS'
5708       include 'COMMON.DERIV'
5709       include 'COMMON.INTERACT'
5710       include 'COMMON.CONTACTS'
5711       double precision gx(3),gx1(3)
5712       logical lprn
5713
5714 C Set lprn=.true. for debugging
5715       lprn=.false.
5716
5717       if (lprn) then
5718         write (iout,'(a)') 'Contact function values:'
5719         do i=nnt,nct-2
5720           write (iout,'(i2,20(1x,i2,f10.5))')
5721      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5722         enddo
5723       endif
5724       ecorr=0.0D0
5725       do i=nnt,nct
5726         do j=1,3
5727           gradcorr(j,i)=0.0D0
5728           gradxorr(j,i)=0.0D0
5729         enddo
5730       enddo
5731       do i=nnt,nct-2
5732
5733         DO ISHIFT = 3,4
5734
5735         i1=i+ishift
5736         num_conti=num_cont(i)
5737         num_conti1=num_cont(i1)
5738         do jj=1,num_conti
5739           j=jcont(jj,i)
5740           do kk=1,num_conti1
5741             j1=jcont(kk,i1)
5742             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5743 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5744 cd   &                   ' ishift=',ishift
5745 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5746 C The system gains extra energy.
5747               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5748             endif   ! j1==j+-ishift
5749           enddo     ! kk
5750         enddo       ! jj
5751
5752         ENDDO ! ISHIFT
5753
5754       enddo         ! i
5755       return
5756       end
5757 c------------------------------------------------------------------------------
5758       double precision function esccorr(i,j,k,l,jj,kk)
5759       implicit real*8 (a-h,o-z)
5760       include 'DIMENSIONS'
5761       include 'COMMON.IOUNITS'
5762       include 'COMMON.DERIV'
5763       include 'COMMON.INTERACT'
5764       include 'COMMON.CONTACTS'
5765       double precision gx(3),gx1(3)
5766       logical lprn
5767       lprn=.false.
5768       eij=facont(jj,i)
5769       ekl=facont(kk,k)
5770 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5771 C Calculate the multi-body contribution to energy.
5772 C Calculate multi-body contributions to the gradient.
5773 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5774 cd   & k,l,(gacont(m,kk,k),m=1,3)
5775       do m=1,3
5776         gx(m) =ekl*gacont(m,jj,i)
5777         gx1(m)=eij*gacont(m,kk,k)
5778         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5779         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5780         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5781         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5782       enddo
5783       do m=i,j-1
5784         do ll=1,3
5785           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5786         enddo
5787       enddo
5788       do m=k,l-1
5789         do ll=1,3
5790           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5791         enddo
5792       enddo
5793       esccorr=-eij*ekl
5794       return
5795       end
5796 c------------------------------------------------------------------------------
5797       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5798 C This subroutine calculates multi-body contributions to hydrogen-bonding
5799       implicit real*8 (a-h,o-z)
5800       include 'DIMENSIONS'
5801       include 'COMMON.IOUNITS'
5802 #ifdef MPI
5803       include "mpif.h"
5804       parameter (max_cont=maxconts)
5805       parameter (max_dim=26)
5806       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5807       double precision zapas(max_dim,maxconts,max_fg_procs),
5808      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5809       common /przechowalnia/ zapas
5810       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5811      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5812 #endif
5813       include 'COMMON.SETUP'
5814       include 'COMMON.FFIELD'
5815       include 'COMMON.DERIV'
5816       include 'COMMON.INTERACT'
5817       include 'COMMON.CONTACTS'
5818       include 'COMMON.CONTROL'
5819       include 'COMMON.LOCAL'
5820       double precision gx(3),gx1(3),time00
5821       logical lprn,ldone
5822
5823 C Set lprn=.true. for debugging
5824       lprn=.false.
5825 #ifdef MPI
5826       n_corr=0
5827       n_corr1=0
5828       if (nfgtasks.le.1) goto 30
5829       if (lprn) then
5830         write (iout,'(a)') 'Contact function values before RECEIVE:'
5831         do i=nnt,nct-2
5832           write (iout,'(2i3,50(1x,i2,f5.2))')
5833      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5834      &    j=1,num_cont_hb(i))
5835         enddo
5836       endif
5837       call flush(iout)
5838       do i=1,ntask_cont_from
5839         ncont_recv(i)=0
5840       enddo
5841       do i=1,ntask_cont_to
5842         ncont_sent(i)=0
5843       enddo
5844 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5845 c     & ntask_cont_to
5846 C Make the list of contacts to send to send to other procesors
5847 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5848 c      call flush(iout)
5849       do i=iturn3_start,iturn3_end
5850 c        write (iout,*) "make contact list turn3",i," num_cont",
5851 c     &    num_cont_hb(i)
5852         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5853       enddo
5854       do i=iturn4_start,iturn4_end
5855 c        write (iout,*) "make contact list turn4",i," num_cont",
5856 c     &   num_cont_hb(i)
5857         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5858       enddo
5859       do ii=1,nat_sent
5860         i=iat_sent(ii)
5861 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5862 c     &    num_cont_hb(i)
5863         do j=1,num_cont_hb(i)
5864         do k=1,4
5865           jjc=jcont_hb(j,i)
5866           iproc=iint_sent_local(k,jjc,ii)
5867 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5868           if (iproc.gt.0) then
5869             ncont_sent(iproc)=ncont_sent(iproc)+1
5870             nn=ncont_sent(iproc)
5871             zapas(1,nn,iproc)=i
5872             zapas(2,nn,iproc)=jjc
5873             zapas(3,nn,iproc)=facont_hb(j,i)
5874             zapas(4,nn,iproc)=ees0p(j,i)
5875             zapas(5,nn,iproc)=ees0m(j,i)
5876             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5877             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5878             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5879             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5880             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5881             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5882             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5883             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5884             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5885             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5886             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5887             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5888             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5889             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5890             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5891             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5892             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5893             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5894             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5895             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5896             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5897           endif
5898         enddo
5899         enddo
5900       enddo
5901       if (lprn) then
5902       write (iout,*)
5903      &  "Numbers of contacts to be sent to other processors",
5904      &  (ncont_sent(i),i=1,ntask_cont_to)
5905       write (iout,*) "Contacts sent"
5906       do ii=1,ntask_cont_to
5907         nn=ncont_sent(ii)
5908         iproc=itask_cont_to(ii)
5909         write (iout,*) nn," contacts to processor",iproc,
5910      &   " of CONT_TO_COMM group"
5911         do i=1,nn
5912           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5913         enddo
5914       enddo
5915       call flush(iout)
5916       endif
5917       CorrelType=477
5918       CorrelID=fg_rank+1
5919       CorrelType1=478
5920       CorrelID1=nfgtasks+fg_rank+1
5921       ireq=0
5922 C Receive the numbers of needed contacts from other processors
5923       do ii=1,ntask_cont_from
5924         iproc=itask_cont_from(ii)
5925         ireq=ireq+1
5926         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
5927      &    FG_COMM,req(ireq),IERR)
5928       enddo
5929 c      write (iout,*) "IRECV ended"
5930 c      call flush(iout)
5931 C Send the number of contacts needed by other processors
5932       do ii=1,ntask_cont_to
5933         iproc=itask_cont_to(ii)
5934         ireq=ireq+1
5935         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
5936      &    FG_COMM,req(ireq),IERR)
5937       enddo
5938 c      write (iout,*) "ISEND ended"
5939 c      write (iout,*) "number of requests (nn)",ireq
5940       call flush(iout)
5941       if (ireq.gt.0)
5942      &  call MPI_Waitall(ireq,req,status_array,ierr)
5943 c      write (iout,*)
5944 c     &  "Numbers of contacts to be received from other processors",
5945 c     &  (ncont_recv(i),i=1,ntask_cont_from)
5946 c      call flush(iout)
5947 C Receive contacts
5948       ireq=0
5949       do ii=1,ntask_cont_from
5950         iproc=itask_cont_from(ii)
5951         nn=ncont_recv(ii)
5952 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
5953 c     &   " of CONT_TO_COMM group"
5954         call flush(iout)
5955         if (nn.gt.0) then
5956           ireq=ireq+1
5957           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
5958      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
5959 c          write (iout,*) "ireq,req",ireq,req(ireq)
5960         endif
5961       enddo
5962 C Send the contacts to processors that need them
5963       do ii=1,ntask_cont_to
5964         iproc=itask_cont_to(ii)
5965         nn=ncont_sent(ii)
5966 c        write (iout,*) nn," contacts to processor",iproc,
5967 c     &   " of CONT_TO_COMM group"
5968         if (nn.gt.0) then
5969           ireq=ireq+1
5970           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
5971      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
5972 c          write (iout,*) "ireq,req",ireq,req(ireq)
5973 c          do i=1,nn
5974 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5975 c          enddo
5976         endif
5977       enddo
5978 c      write (iout,*) "number of requests (contacts)",ireq
5979 c      write (iout,*) "req",(req(i),i=1,4)
5980 c      call flush(iout)
5981       if (ireq.gt.0)
5982      & call MPI_Waitall(ireq,req,status_array,ierr)
5983       do iii=1,ntask_cont_from
5984         iproc=itask_cont_from(iii)
5985         nn=ncont_recv(iii)
5986         if (lprn) then
5987         write (iout,*) "Received",nn," contacts from processor",iproc,
5988      &   " of CONT_FROM_COMM group"
5989         call flush(iout)
5990         do i=1,nn
5991           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
5992         enddo
5993         call flush(iout)
5994         endif
5995         do i=1,nn
5996           ii=zapas_recv(1,i,iii)
5997 c Flag the received contacts to prevent double-counting
5998           jj=-zapas_recv(2,i,iii)
5999 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6000 c          call flush(iout)
6001           nnn=num_cont_hb(ii)+1
6002           num_cont_hb(ii)=nnn
6003           jcont_hb(nnn,ii)=jj
6004           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6005           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6006           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6007           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6008           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6009           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6010           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6011           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6012           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6013           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6014           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6015           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6016           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6017           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6018           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6019           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6020           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6021           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6022           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6023           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6024           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6025           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6026           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6027           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6028         enddo
6029       enddo
6030       call flush(iout)
6031       if (lprn) then
6032         write (iout,'(a)') 'Contact function values after receive:'
6033         do i=nnt,nct-2
6034           write (iout,'(2i3,50(1x,i3,f5.2))')
6035      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6036      &    j=1,num_cont_hb(i))
6037         enddo
6038         call flush(iout)
6039       endif
6040    30 continue
6041 #endif
6042       if (lprn) then
6043         write (iout,'(a)') 'Contact function values:'
6044         do i=nnt,nct-2
6045           write (iout,'(2i3,50(1x,i3,f5.2))')
6046      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6047      &    j=1,num_cont_hb(i))
6048         enddo
6049       endif
6050       ecorr=0.0D0
6051 C Remove the loop below after debugging !!!
6052       do i=nnt,nct
6053         do j=1,3
6054           gradcorr(j,i)=0.0D0
6055           gradxorr(j,i)=0.0D0
6056         enddo
6057       enddo
6058 C Calculate the local-electrostatic correlation terms
6059       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6060         i1=i+1
6061         num_conti=num_cont_hb(i)
6062         num_conti1=num_cont_hb(i+1)
6063         do jj=1,num_conti
6064           j=jcont_hb(jj,i)
6065           jp=iabs(j)
6066           do kk=1,num_conti1
6067             j1=jcont_hb(kk,i1)
6068             jp1=iabs(j1)
6069 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6070 c     &         ' jj=',jj,' kk=',kk
6071             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6072      &          .or. j.lt.0 .and. j1.gt.0) .and.
6073      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6074 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6075 C The system gains extra energy.
6076               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6077               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6078      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6079               n_corr=n_corr+1
6080             else if (j1.eq.j) then
6081 C Contacts I-J and I-(J+1) occur simultaneously.
6082 C The system loses extra energy.
6083 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6084             endif
6085           enddo ! kk
6086           do kk=1,num_conti
6087             j1=jcont_hb(kk,i)
6088 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6089 c    &         ' jj=',jj,' kk=',kk
6090             if (j1.eq.j+1) then
6091 C Contacts I-J and (I+1)-J occur simultaneously.
6092 C The system loses extra energy.
6093 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6094             endif ! j1==j+1
6095           enddo ! kk
6096         enddo ! jj
6097       enddo ! i
6098       return
6099       end
6100 c------------------------------------------------------------------------------
6101       subroutine add_hb_contact(ii,jj,itask)
6102       implicit real*8 (a-h,o-z)
6103       include "DIMENSIONS"
6104       include "COMMON.IOUNITS"
6105       integer max_cont
6106       integer max_dim
6107       parameter (max_cont=maxconts)
6108       parameter (max_dim=26)
6109       include "COMMON.CONTACTS"
6110       double precision zapas(max_dim,maxconts,max_fg_procs),
6111      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6112       common /przechowalnia/ zapas
6113       integer i,j,ii,jj,iproc,itask(4),nn
6114 c      write (iout,*) "itask",itask
6115       do i=1,2
6116         iproc=itask(i)
6117         if (iproc.gt.0) then
6118           do j=1,num_cont_hb(ii)
6119             jjc=jcont_hb(j,ii)
6120 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6121             if (jjc.eq.jj) then
6122               ncont_sent(iproc)=ncont_sent(iproc)+1
6123               nn=ncont_sent(iproc)
6124               zapas(1,nn,iproc)=ii
6125               zapas(2,nn,iproc)=jjc
6126               zapas(3,nn,iproc)=facont_hb(j,ii)
6127               zapas(4,nn,iproc)=ees0p(j,ii)
6128               zapas(5,nn,iproc)=ees0m(j,ii)
6129               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6130               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6131               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6132               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6133               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6134               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6135               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6136               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6137               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6138               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6139               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6140               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6141               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6142               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6143               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6144               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6145               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6146               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6147               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6148               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6149               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6150               exit
6151             endif
6152           enddo
6153         endif
6154       enddo
6155       return
6156       end
6157 c------------------------------------------------------------------------------
6158       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6159      &  n_corr1)
6160 C This subroutine calculates multi-body contributions to hydrogen-bonding
6161       implicit real*8 (a-h,o-z)
6162       include 'DIMENSIONS'
6163       include 'COMMON.IOUNITS'
6164 #ifdef MPI
6165       include "mpif.h"
6166       parameter (max_cont=maxconts)
6167       parameter (max_dim=70)
6168       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6169       double precision zapas(max_dim,maxconts,max_fg_procs),
6170      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6171       common /przechowalnia/ zapas
6172       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6173      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6174 #endif
6175       include 'COMMON.SETUP'
6176       include 'COMMON.FFIELD'
6177       include 'COMMON.DERIV'
6178       include 'COMMON.LOCAL'
6179       include 'COMMON.INTERACT'
6180       include 'COMMON.CONTACTS'
6181       include 'COMMON.CHAIN'
6182       include 'COMMON.CONTROL'
6183       double precision gx(3),gx1(3)
6184       integer num_cont_hb_old(maxres)
6185       logical lprn,ldone
6186       double precision eello4,eello5,eelo6,eello_turn6
6187       external eello4,eello5,eello6,eello_turn6
6188 C Set lprn=.true. for debugging
6189       lprn=.false.
6190       eturn6=0.0d0
6191 #ifdef MPI
6192       do i=1,nres
6193         num_cont_hb_old(i)=num_cont_hb(i)
6194       enddo
6195       n_corr=0
6196       n_corr1=0
6197       if (nfgtasks.le.1) goto 30
6198       if (lprn) then
6199         write (iout,'(a)') 'Contact function values before RECEIVE:'
6200         do i=nnt,nct-2
6201           write (iout,'(2i3,50(1x,i2,f5.2))')
6202      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6203      &    j=1,num_cont_hb(i))
6204         enddo
6205       endif
6206       call flush(iout)
6207       do i=1,ntask_cont_from
6208         ncont_recv(i)=0
6209       enddo
6210       do i=1,ntask_cont_to
6211         ncont_sent(i)=0
6212       enddo
6213 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6214 c     & ntask_cont_to
6215 C Make the list of contacts to send to send to other procesors
6216       do i=iturn3_start,iturn3_end
6217 c        write (iout,*) "make contact list turn3",i," num_cont",
6218 c     &    num_cont_hb(i)
6219         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6220       enddo
6221       do i=iturn4_start,iturn4_end
6222 c        write (iout,*) "make contact list turn4",i," num_cont",
6223 c     &   num_cont_hb(i)
6224         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6225       enddo
6226       do ii=1,nat_sent
6227         i=iat_sent(ii)
6228 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6229 c     &    num_cont_hb(i)
6230         do j=1,num_cont_hb(i)
6231         do k=1,4
6232           jjc=jcont_hb(j,i)
6233           iproc=iint_sent_local(k,jjc,ii)
6234 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6235           if (iproc.ne.0) then
6236             ncont_sent(iproc)=ncont_sent(iproc)+1
6237             nn=ncont_sent(iproc)
6238             zapas(1,nn,iproc)=i
6239             zapas(2,nn,iproc)=jjc
6240             zapas(3,nn,iproc)=d_cont(j,i)
6241             ind=3
6242             do kk=1,3
6243               ind=ind+1
6244               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6245             enddo
6246             do kk=1,2
6247               do ll=1,2
6248                 ind=ind+1
6249                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6250               enddo
6251             enddo
6252             do jj=1,5
6253               do kk=1,3
6254                 do ll=1,2
6255                   do mm=1,2
6256                     ind=ind+1
6257                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6258                   enddo
6259                 enddo
6260               enddo
6261             enddo
6262           endif
6263         enddo
6264         enddo
6265       enddo
6266       if (lprn) then
6267       write (iout,*)
6268      &  "Numbers of contacts to be sent to other processors",
6269      &  (ncont_sent(i),i=1,ntask_cont_to)
6270       write (iout,*) "Contacts sent"
6271       do ii=1,ntask_cont_to
6272         nn=ncont_sent(ii)
6273         iproc=itask_cont_to(ii)
6274         write (iout,*) nn," contacts to processor",iproc,
6275      &   " of CONT_TO_COMM group"
6276         do i=1,nn
6277           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6278         enddo
6279       enddo
6280       call flush(iout)
6281       endif
6282       CorrelType=477
6283       CorrelID=fg_rank+1
6284       CorrelType1=478
6285       CorrelID1=nfgtasks+fg_rank+1
6286       ireq=0
6287 C Receive the numbers of needed contacts from other processors
6288       do ii=1,ntask_cont_from
6289         iproc=itask_cont_from(ii)
6290         ireq=ireq+1
6291         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6292      &    FG_COMM,req(ireq),IERR)
6293       enddo
6294 c      write (iout,*) "IRECV ended"
6295 c      call flush(iout)
6296 C Send the number of contacts needed by other processors
6297       do ii=1,ntask_cont_to
6298         iproc=itask_cont_to(ii)
6299         ireq=ireq+1
6300         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6301      &    FG_COMM,req(ireq),IERR)
6302       enddo
6303 c      write (iout,*) "ISEND ended"
6304 c      write (iout,*) "number of requests (nn)",ireq
6305       call flush(iout)
6306       if (ireq.gt.0)
6307      &  call MPI_Waitall(ireq,req,status_array,ierr)
6308 c      write (iout,*)
6309 c     &  "Numbers of contacts to be received from other processors",
6310 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6311 c      call flush(iout)
6312 C Receive contacts
6313       ireq=0
6314       do ii=1,ntask_cont_from
6315         iproc=itask_cont_from(ii)
6316         nn=ncont_recv(ii)
6317 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6318 c     &   " of CONT_TO_COMM group"
6319         call flush(iout)
6320         if (nn.gt.0) then
6321           ireq=ireq+1
6322           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6323      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6324 c          write (iout,*) "ireq,req",ireq,req(ireq)
6325         endif
6326       enddo
6327 C Send the contacts to processors that need them
6328       do ii=1,ntask_cont_to
6329         iproc=itask_cont_to(ii)
6330         nn=ncont_sent(ii)
6331 c        write (iout,*) nn," contacts to processor",iproc,
6332 c     &   " of CONT_TO_COMM group"
6333         if (nn.gt.0) then
6334           ireq=ireq+1
6335           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6336      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6337 c          write (iout,*) "ireq,req",ireq,req(ireq)
6338 c          do i=1,nn
6339 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6340 c          enddo
6341         endif
6342       enddo
6343 c      write (iout,*) "number of requests (contacts)",ireq
6344 c      write (iout,*) "req",(req(i),i=1,4)
6345 c      call flush(iout)
6346       if (ireq.gt.0)
6347      & call MPI_Waitall(ireq,req,status_array,ierr)
6348       do iii=1,ntask_cont_from
6349         iproc=itask_cont_from(iii)
6350         nn=ncont_recv(iii)
6351         if (lprn) then
6352         write (iout,*) "Received",nn," contacts from processor",iproc,
6353      &   " of CONT_FROM_COMM group"
6354         call flush(iout)
6355         do i=1,nn
6356           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6357         enddo
6358         call flush(iout)
6359         endif
6360         do i=1,nn
6361           ii=zapas_recv(1,i,iii)
6362 c Flag the received contacts to prevent double-counting
6363           jj=-zapas_recv(2,i,iii)
6364 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6365 c          call flush(iout)
6366           nnn=num_cont_hb(ii)+1
6367           num_cont_hb(ii)=nnn
6368           jcont_hb(nnn,ii)=jj
6369           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6370           ind=3
6371           do kk=1,3
6372             ind=ind+1
6373             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6374           enddo
6375           do kk=1,2
6376             do ll=1,2
6377               ind=ind+1
6378               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6379             enddo
6380           enddo
6381           do jj=1,5
6382             do kk=1,3
6383               do ll=1,2
6384                 do mm=1,2
6385                   ind=ind+1
6386                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6387                 enddo
6388               enddo
6389             enddo
6390           enddo
6391         enddo
6392       enddo
6393       call flush(iout)
6394       if (lprn) then
6395         write (iout,'(a)') 'Contact function values after receive:'
6396         do i=nnt,nct-2
6397           write (iout,'(2i3,50(1x,i3,5f6.3))')
6398      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6399      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6400         enddo
6401         call flush(iout)
6402       endif
6403    30 continue
6404 #endif
6405       if (lprn) then
6406         write (iout,'(a)') 'Contact function values:'
6407         do i=nnt,nct-2
6408           write (iout,'(2i3,50(1x,i2,5f6.3))')
6409      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6410      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6411         enddo
6412       endif
6413       ecorr=0.0D0
6414       ecorr5=0.0d0
6415       ecorr6=0.0d0
6416 C Remove the loop below after debugging !!!
6417       do i=nnt,nct
6418         do j=1,3
6419           gradcorr(j,i)=0.0D0
6420           gradxorr(j,i)=0.0D0
6421         enddo
6422       enddo
6423 C Calculate the dipole-dipole interaction energies
6424       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6425       do i=iatel_s,iatel_e+1
6426         num_conti=num_cont_hb(i)
6427         do jj=1,num_conti
6428           j=jcont_hb(jj,i)
6429 #ifdef MOMENT
6430           call dipole(i,j,jj)
6431 #endif
6432         enddo
6433       enddo
6434       endif
6435 C Calculate the local-electrostatic correlation terms
6436 c                write (iout,*) "gradcorr5 in eello5 before loop"
6437 c                do iii=1,nres
6438 c                  write (iout,'(i5,3f10.5)')
6439 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6440 c                enddo
6441       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6442 c        write (iout,*) "corr loop i",i
6443         i1=i+1
6444         num_conti=num_cont_hb(i)
6445         num_conti1=num_cont_hb(i+1)
6446         do jj=1,num_conti
6447           j=jcont_hb(jj,i)
6448           jp=iabs(j)
6449           do kk=1,num_conti1
6450             j1=jcont_hb(kk,i1)
6451             jp1=iabs(j1)
6452 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6453 c     &         ' jj=',jj,' kk=',kk
6454 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6455             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6456      &          .or. j.lt.0 .and. j1.gt.0) .and.
6457      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6458 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6459 C The system gains extra energy.
6460               n_corr=n_corr+1
6461               sqd1=dsqrt(d_cont(jj,i))
6462               sqd2=dsqrt(d_cont(kk,i1))
6463               sred_geom = sqd1*sqd2
6464               IF (sred_geom.lt.cutoff_corr) THEN
6465                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6466      &            ekont,fprimcont)
6467 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6468 cd     &         ' jj=',jj,' kk=',kk
6469                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6470                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6471                 do l=1,3
6472                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6473                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6474                 enddo
6475                 n_corr1=n_corr1+1
6476 cd               write (iout,*) 'sred_geom=',sred_geom,
6477 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6478 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6479 cd               write (iout,*) "g_contij",g_contij
6480 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6481 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6482                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6483                 if (wcorr4.gt.0.0d0)
6484      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6485                   if (energy_dec.and.wcorr4.gt.0.0d0)
6486      1                 write (iout,'(a6,4i5,0pf7.3)')
6487      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6488 c                write (iout,*) "gradcorr5 before eello5"
6489 c                do iii=1,nres
6490 c                  write (iout,'(i5,3f10.5)')
6491 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6492 c                enddo
6493                 if (wcorr5.gt.0.0d0)
6494      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6495 c                write (iout,*) "gradcorr5 after eello5"
6496 c                do iii=1,nres
6497 c                  write (iout,'(i5,3f10.5)')
6498 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6499 c                enddo
6500                   if (energy_dec.and.wcorr5.gt.0.0d0)
6501      1                 write (iout,'(a6,4i5,0pf7.3)')
6502      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6503 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6504 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6505                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6506      &               .or. wturn6.eq.0.0d0))then
6507 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6508                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6509                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6510      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6511 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6512 cd     &            'ecorr6=',ecorr6
6513 cd                write (iout,'(4e15.5)') sred_geom,
6514 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6515 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6516 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6517                 else if (wturn6.gt.0.0d0
6518      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6519 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6520                   eturn6=eturn6+eello_turn6(i,jj,kk)
6521                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6522      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6523 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6524                 endif
6525               ENDIF
6526 1111          continue
6527             endif
6528           enddo ! kk
6529         enddo ! jj
6530       enddo ! i
6531       do i=1,nres
6532         num_cont_hb(i)=num_cont_hb_old(i)
6533       enddo
6534 c                write (iout,*) "gradcorr5 in eello5"
6535 c                do iii=1,nres
6536 c                  write (iout,'(i5,3f10.5)')
6537 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6538 c                enddo
6539       return
6540       end
6541 c------------------------------------------------------------------------------
6542       subroutine add_hb_contact_eello(ii,jj,itask)
6543       implicit real*8 (a-h,o-z)
6544       include "DIMENSIONS"
6545       include "COMMON.IOUNITS"
6546       integer max_cont
6547       integer max_dim
6548       parameter (max_cont=maxconts)
6549       parameter (max_dim=70)
6550       include "COMMON.CONTACTS"
6551       double precision zapas(max_dim,maxconts,max_fg_procs),
6552      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6553       common /przechowalnia/ zapas
6554       integer i,j,ii,jj,iproc,itask(4),nn
6555 c      write (iout,*) "itask",itask
6556       do i=1,2
6557         iproc=itask(i)
6558         if (iproc.gt.0) then
6559           do j=1,num_cont_hb(ii)
6560             jjc=jcont_hb(j,ii)
6561 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6562             if (jjc.eq.jj) then
6563               ncont_sent(iproc)=ncont_sent(iproc)+1
6564               nn=ncont_sent(iproc)
6565               zapas(1,nn,iproc)=ii
6566               zapas(2,nn,iproc)=jjc
6567               zapas(3,nn,iproc)=d_cont(j,ii)
6568               ind=3
6569               do kk=1,3
6570                 ind=ind+1
6571                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6572               enddo
6573               do kk=1,2
6574                 do ll=1,2
6575                   ind=ind+1
6576                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6577                 enddo
6578               enddo
6579               do jj=1,5
6580                 do kk=1,3
6581                   do ll=1,2
6582                     do mm=1,2
6583                       ind=ind+1
6584                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6585                     enddo
6586                   enddo
6587                 enddo
6588               enddo
6589               exit
6590             endif
6591           enddo
6592         endif
6593       enddo
6594       return
6595       end
6596 c------------------------------------------------------------------------------
6597       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6598       implicit real*8 (a-h,o-z)
6599       include 'DIMENSIONS'
6600       include 'COMMON.IOUNITS'
6601       include 'COMMON.DERIV'
6602       include 'COMMON.INTERACT'
6603       include 'COMMON.CONTACTS'
6604       double precision gx(3),gx1(3)
6605       logical lprn
6606       lprn=.false.
6607       eij=facont_hb(jj,i)
6608       ekl=facont_hb(kk,k)
6609       ees0pij=ees0p(jj,i)
6610       ees0pkl=ees0p(kk,k)
6611       ees0mij=ees0m(jj,i)
6612       ees0mkl=ees0m(kk,k)
6613       ekont=eij*ekl
6614       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6615 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6616 C Following 4 lines for diagnostics.
6617 cd    ees0pkl=0.0D0
6618 cd    ees0pij=1.0D0
6619 cd    ees0mkl=0.0D0
6620 cd    ees0mij=1.0D0
6621 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6622 c     & 'Contacts ',i,j,
6623 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6624 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6625 c     & 'gradcorr_long'
6626 C Calculate the multi-body contribution to energy.
6627 c      ecorr=ecorr+ekont*ees
6628 C Calculate multi-body contributions to the gradient.
6629       coeffpees0pij=coeffp*ees0pij
6630       coeffmees0mij=coeffm*ees0mij
6631       coeffpees0pkl=coeffp*ees0pkl
6632       coeffmees0mkl=coeffm*ees0mkl
6633       do ll=1,3
6634 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6635         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6636      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6637      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6638         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6639      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6640      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6641 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6642         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6643      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6644      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6645         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6646      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6647      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6648         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6649      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6650      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6651         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6652         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6653         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6654      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6655      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6656         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6657         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6658 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6659       enddo
6660 c      write (iout,*)
6661 cgrad      do m=i+1,j-1
6662 cgrad        do ll=1,3
6663 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6664 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6665 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6666 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6667 cgrad        enddo
6668 cgrad      enddo
6669 cgrad      do m=k+1,l-1
6670 cgrad        do ll=1,3
6671 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6672 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6673 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6674 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6675 cgrad        enddo
6676 cgrad      enddo
6677 c      write (iout,*) "ehbcorr",ekont*ees
6678       ehbcorr=ekont*ees
6679       return
6680       end
6681 #ifdef MOMENT
6682 C---------------------------------------------------------------------------
6683       subroutine dipole(i,j,jj)
6684       implicit real*8 (a-h,o-z)
6685       include 'DIMENSIONS'
6686       include 'COMMON.IOUNITS'
6687       include 'COMMON.CHAIN'
6688       include 'COMMON.FFIELD'
6689       include 'COMMON.DERIV'
6690       include 'COMMON.INTERACT'
6691       include 'COMMON.CONTACTS'
6692       include 'COMMON.TORSION'
6693       include 'COMMON.VAR'
6694       include 'COMMON.GEO'
6695       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6696      &  auxmat(2,2)
6697       iti1 = itortyp(itype(i+1))
6698       if (j.lt.nres-1) then
6699         itj1 = itortyp(itype(j+1))
6700       else
6701         itj1=ntortyp+1
6702       endif
6703       do iii=1,2
6704         dipi(iii,1)=Ub2(iii,i)
6705         dipderi(iii)=Ub2der(iii,i)
6706         dipi(iii,2)=b1(iii,iti1)
6707         dipj(iii,1)=Ub2(iii,j)
6708         dipderj(iii)=Ub2der(iii,j)
6709         dipj(iii,2)=b1(iii,itj1)
6710       enddo
6711       kkk=0
6712       do iii=1,2
6713         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6714         do jjj=1,2
6715           kkk=kkk+1
6716           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6717         enddo
6718       enddo
6719       do kkk=1,5
6720         do lll=1,3
6721           mmm=0
6722           do iii=1,2
6723             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6724      &        auxvec(1))
6725             do jjj=1,2
6726               mmm=mmm+1
6727               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6728             enddo
6729           enddo
6730         enddo
6731       enddo
6732       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6733       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6734       do iii=1,2
6735         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6736       enddo
6737       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6738       do iii=1,2
6739         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6740       enddo
6741       return
6742       end
6743 #endif
6744 C---------------------------------------------------------------------------
6745       subroutine calc_eello(i,j,k,l,jj,kk)
6746 C
6747 C This subroutine computes matrices and vectors needed to calculate
6748 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6749 C
6750       implicit real*8 (a-h,o-z)
6751       include 'DIMENSIONS'
6752       include 'COMMON.IOUNITS'
6753       include 'COMMON.CHAIN'
6754       include 'COMMON.DERIV'
6755       include 'COMMON.INTERACT'
6756       include 'COMMON.CONTACTS'
6757       include 'COMMON.TORSION'
6758       include 'COMMON.VAR'
6759       include 'COMMON.GEO'
6760       include 'COMMON.FFIELD'
6761       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6762      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6763       logical lprn
6764       common /kutas/ lprn
6765 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6766 cd     & ' jj=',jj,' kk=',kk
6767 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6768 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6769 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6770       do iii=1,2
6771         do jjj=1,2
6772           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6773           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6774         enddo
6775       enddo
6776       call transpose2(aa1(1,1),aa1t(1,1))
6777       call transpose2(aa2(1,1),aa2t(1,1))
6778       do kkk=1,5
6779         do lll=1,3
6780           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6781      &      aa1tder(1,1,lll,kkk))
6782           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6783      &      aa2tder(1,1,lll,kkk))
6784         enddo
6785       enddo
6786       if (l.eq.j+1) then
6787 C parallel orientation of the two CA-CA-CA frames.
6788         if (i.gt.1) then
6789           iti=itortyp(itype(i))
6790         else
6791           iti=ntortyp+1
6792         endif
6793         itk1=itortyp(itype(k+1))
6794         itj=itortyp(itype(j))
6795         if (l.lt.nres-1) then
6796           itl1=itortyp(itype(l+1))
6797         else
6798           itl1=ntortyp+1
6799         endif
6800 C A1 kernel(j+1) A2T
6801 cd        do iii=1,2
6802 cd          write (iout,'(3f10.5,5x,3f10.5)')
6803 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6804 cd        enddo
6805         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6806      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6807      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6808 C Following matrices are needed only for 6-th order cumulants
6809         IF (wcorr6.gt.0.0d0) THEN
6810         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6811      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6812      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6813         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6814      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6815      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6816      &   ADtEAderx(1,1,1,1,1,1))
6817         lprn=.false.
6818         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6819      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6820      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6821      &   ADtEA1derx(1,1,1,1,1,1))
6822         ENDIF
6823 C End 6-th order cumulants
6824 cd        lprn=.false.
6825 cd        if (lprn) then
6826 cd        write (2,*) 'In calc_eello6'
6827 cd        do iii=1,2
6828 cd          write (2,*) 'iii=',iii
6829 cd          do kkk=1,5
6830 cd            write (2,*) 'kkk=',kkk
6831 cd            do jjj=1,2
6832 cd              write (2,'(3(2f10.5),5x)')
6833 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6834 cd            enddo
6835 cd          enddo
6836 cd        enddo
6837 cd        endif
6838         call transpose2(EUgder(1,1,k),auxmat(1,1))
6839         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6840         call transpose2(EUg(1,1,k),auxmat(1,1))
6841         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6842         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6843         do iii=1,2
6844           do kkk=1,5
6845             do lll=1,3
6846               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6847      &          EAEAderx(1,1,lll,kkk,iii,1))
6848             enddo
6849           enddo
6850         enddo
6851 C A1T kernel(i+1) A2
6852         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6853      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6854      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6855 C Following matrices are needed only for 6-th order cumulants
6856         IF (wcorr6.gt.0.0d0) THEN
6857         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6858      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6859      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6860         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6861      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6862      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6863      &   ADtEAderx(1,1,1,1,1,2))
6864         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6865      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6866      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6867      &   ADtEA1derx(1,1,1,1,1,2))
6868         ENDIF
6869 C End 6-th order cumulants
6870         call transpose2(EUgder(1,1,l),auxmat(1,1))
6871         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6872         call transpose2(EUg(1,1,l),auxmat(1,1))
6873         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6874         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6875         do iii=1,2
6876           do kkk=1,5
6877             do lll=1,3
6878               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6879      &          EAEAderx(1,1,lll,kkk,iii,2))
6880             enddo
6881           enddo
6882         enddo
6883 C AEAb1 and AEAb2
6884 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6885 C They are needed only when the fifth- or the sixth-order cumulants are
6886 C indluded.
6887         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6888         call transpose2(AEA(1,1,1),auxmat(1,1))
6889         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6890         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6891         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6892         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6893         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6894         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6895         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6896         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6897         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6898         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6899         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6900         call transpose2(AEA(1,1,2),auxmat(1,1))
6901         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6902         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6903         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6904         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6905         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6906         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6907         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6908         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6909         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6910         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6911         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6912 C Calculate the Cartesian derivatives of the vectors.
6913         do iii=1,2
6914           do kkk=1,5
6915             do lll=1,3
6916               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6917               call matvec2(auxmat(1,1),b1(1,iti),
6918      &          AEAb1derx(1,lll,kkk,iii,1,1))
6919               call matvec2(auxmat(1,1),Ub2(1,i),
6920      &          AEAb2derx(1,lll,kkk,iii,1,1))
6921               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6922      &          AEAb1derx(1,lll,kkk,iii,2,1))
6923               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6924      &          AEAb2derx(1,lll,kkk,iii,2,1))
6925               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6926               call matvec2(auxmat(1,1),b1(1,itj),
6927      &          AEAb1derx(1,lll,kkk,iii,1,2))
6928               call matvec2(auxmat(1,1),Ub2(1,j),
6929      &          AEAb2derx(1,lll,kkk,iii,1,2))
6930               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6931      &          AEAb1derx(1,lll,kkk,iii,2,2))
6932               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6933      &          AEAb2derx(1,lll,kkk,iii,2,2))
6934             enddo
6935           enddo
6936         enddo
6937         ENDIF
6938 C End vectors
6939       else
6940 C Antiparallel orientation of the two CA-CA-CA frames.
6941         if (i.gt.1) then
6942           iti=itortyp(itype(i))
6943         else
6944           iti=ntortyp+1
6945         endif
6946         itk1=itortyp(itype(k+1))
6947         itl=itortyp(itype(l))
6948         itj=itortyp(itype(j))
6949         if (j.lt.nres-1) then
6950           itj1=itortyp(itype(j+1))
6951         else
6952           itj1=ntortyp+1
6953         endif
6954 C A2 kernel(j-1)T A1T
6955         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6956      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6957      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6958 C Following matrices are needed only for 6-th order cumulants
6959         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6960      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6961         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6962      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6963      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6964         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6965      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6966      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6967      &   ADtEAderx(1,1,1,1,1,1))
6968         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6969      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6970      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6971      &   ADtEA1derx(1,1,1,1,1,1))
6972         ENDIF
6973 C End 6-th order cumulants
6974         call transpose2(EUgder(1,1,k),auxmat(1,1))
6975         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6976         call transpose2(EUg(1,1,k),auxmat(1,1))
6977         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6978         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6979         do iii=1,2
6980           do kkk=1,5
6981             do lll=1,3
6982               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6983      &          EAEAderx(1,1,lll,kkk,iii,1))
6984             enddo
6985           enddo
6986         enddo
6987 C A2T kernel(i+1)T A1
6988         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6989      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6990      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6991 C Following matrices are needed only for 6-th order cumulants
6992         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6993      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6994         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6995      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6996      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6997         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6998      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6999      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7000      &   ADtEAderx(1,1,1,1,1,2))
7001         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7002      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7003      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7004      &   ADtEA1derx(1,1,1,1,1,2))
7005         ENDIF
7006 C End 6-th order cumulants
7007         call transpose2(EUgder(1,1,j),auxmat(1,1))
7008         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7009         call transpose2(EUg(1,1,j),auxmat(1,1))
7010         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7011         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7012         do iii=1,2
7013           do kkk=1,5
7014             do lll=1,3
7015               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7016      &          EAEAderx(1,1,lll,kkk,iii,2))
7017             enddo
7018           enddo
7019         enddo
7020 C AEAb1 and AEAb2
7021 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7022 C They are needed only when the fifth- or the sixth-order cumulants are
7023 C indluded.
7024         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7025      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7026         call transpose2(AEA(1,1,1),auxmat(1,1))
7027         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7028         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7029         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7030         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7031         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7032         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7033         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7034         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7035         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7036         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7037         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7038         call transpose2(AEA(1,1,2),auxmat(1,1))
7039         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7040         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7041         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7042         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7043         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7044         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7045         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7046         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7047         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7048         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7049         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7050 C Calculate the Cartesian derivatives of the vectors.
7051         do iii=1,2
7052           do kkk=1,5
7053             do lll=1,3
7054               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7055               call matvec2(auxmat(1,1),b1(1,iti),
7056      &          AEAb1derx(1,lll,kkk,iii,1,1))
7057               call matvec2(auxmat(1,1),Ub2(1,i),
7058      &          AEAb2derx(1,lll,kkk,iii,1,1))
7059               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7060      &          AEAb1derx(1,lll,kkk,iii,2,1))
7061               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7062      &          AEAb2derx(1,lll,kkk,iii,2,1))
7063               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7064               call matvec2(auxmat(1,1),b1(1,itl),
7065      &          AEAb1derx(1,lll,kkk,iii,1,2))
7066               call matvec2(auxmat(1,1),Ub2(1,l),
7067      &          AEAb2derx(1,lll,kkk,iii,1,2))
7068               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7069      &          AEAb1derx(1,lll,kkk,iii,2,2))
7070               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7071      &          AEAb2derx(1,lll,kkk,iii,2,2))
7072             enddo
7073           enddo
7074         enddo
7075         ENDIF
7076 C End vectors
7077       endif
7078       return
7079       end
7080 C---------------------------------------------------------------------------
7081       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7082      &  KK,KKderg,AKA,AKAderg,AKAderx)
7083       implicit none
7084       integer nderg
7085       logical transp
7086       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7087      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7088      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7089       integer iii,kkk,lll
7090       integer jjj,mmm
7091       logical lprn
7092       common /kutas/ lprn
7093       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7094       do iii=1,nderg
7095         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7096      &    AKAderg(1,1,iii))
7097       enddo
7098 cd      if (lprn) write (2,*) 'In kernel'
7099       do kkk=1,5
7100 cd        if (lprn) write (2,*) 'kkk=',kkk
7101         do lll=1,3
7102           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7103      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7104 cd          if (lprn) then
7105 cd            write (2,*) 'lll=',lll
7106 cd            write (2,*) 'iii=1'
7107 cd            do jjj=1,2
7108 cd              write (2,'(3(2f10.5),5x)')
7109 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7110 cd            enddo
7111 cd          endif
7112           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7113      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7114 cd          if (lprn) then
7115 cd            write (2,*) 'lll=',lll
7116 cd            write (2,*) 'iii=2'
7117 cd            do jjj=1,2
7118 cd              write (2,'(3(2f10.5),5x)')
7119 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7120 cd            enddo
7121 cd          endif
7122         enddo
7123       enddo
7124       return
7125       end
7126 C---------------------------------------------------------------------------
7127       double precision function eello4(i,j,k,l,jj,kk)
7128       implicit real*8 (a-h,o-z)
7129       include 'DIMENSIONS'
7130       include 'COMMON.IOUNITS'
7131       include 'COMMON.CHAIN'
7132       include 'COMMON.DERIV'
7133       include 'COMMON.INTERACT'
7134       include 'COMMON.CONTACTS'
7135       include 'COMMON.TORSION'
7136       include 'COMMON.VAR'
7137       include 'COMMON.GEO'
7138       double precision pizda(2,2),ggg1(3),ggg2(3)
7139 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7140 cd        eello4=0.0d0
7141 cd        return
7142 cd      endif
7143 cd      print *,'eello4:',i,j,k,l,jj,kk
7144 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7145 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7146 cold      eij=facont_hb(jj,i)
7147 cold      ekl=facont_hb(kk,k)
7148 cold      ekont=eij*ekl
7149       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7150 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7151       gcorr_loc(k-1)=gcorr_loc(k-1)
7152      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7153       if (l.eq.j+1) then
7154         gcorr_loc(l-1)=gcorr_loc(l-1)
7155      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7156       else
7157         gcorr_loc(j-1)=gcorr_loc(j-1)
7158      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7159       endif
7160       do iii=1,2
7161         do kkk=1,5
7162           do lll=1,3
7163             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7164      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7165 cd            derx(lll,kkk,iii)=0.0d0
7166           enddo
7167         enddo
7168       enddo
7169 cd      gcorr_loc(l-1)=0.0d0
7170 cd      gcorr_loc(j-1)=0.0d0
7171 cd      gcorr_loc(k-1)=0.0d0
7172 cd      eel4=1.0d0
7173 cd      write (iout,*)'Contacts have occurred for peptide groups',
7174 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7175 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7176       if (j.lt.nres-1) then
7177         j1=j+1
7178         j2=j-1
7179       else
7180         j1=j-1
7181         j2=j-2
7182       endif
7183       if (l.lt.nres-1) then
7184         l1=l+1
7185         l2=l-1
7186       else
7187         l1=l-1
7188         l2=l-2
7189       endif
7190       do ll=1,3
7191 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7192 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7193         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7194         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7195 cgrad        ghalf=0.5d0*ggg1(ll)
7196         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7197         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7198         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7199         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7200         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7201         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7202 cgrad        ghalf=0.5d0*ggg2(ll)
7203         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7204         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7205         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7206         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7207         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7208         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7209       enddo
7210 cgrad      do m=i+1,j-1
7211 cgrad        do ll=1,3
7212 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7213 cgrad        enddo
7214 cgrad      enddo
7215 cgrad      do m=k+1,l-1
7216 cgrad        do ll=1,3
7217 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7218 cgrad        enddo
7219 cgrad      enddo
7220 cgrad      do m=i+2,j2
7221 cgrad        do ll=1,3
7222 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7223 cgrad        enddo
7224 cgrad      enddo
7225 cgrad      do m=k+2,l2
7226 cgrad        do ll=1,3
7227 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7228 cgrad        enddo
7229 cgrad      enddo
7230 cd      do iii=1,nres-3
7231 cd        write (2,*) iii,gcorr_loc(iii)
7232 cd      enddo
7233       eello4=ekont*eel4
7234 cd      write (2,*) 'ekont',ekont
7235 cd      write (iout,*) 'eello4',ekont*eel4
7236       return
7237       end
7238 C---------------------------------------------------------------------------
7239       double precision function eello5(i,j,k,l,jj,kk)
7240       implicit real*8 (a-h,o-z)
7241       include 'DIMENSIONS'
7242       include 'COMMON.IOUNITS'
7243       include 'COMMON.CHAIN'
7244       include 'COMMON.DERIV'
7245       include 'COMMON.INTERACT'
7246       include 'COMMON.CONTACTS'
7247       include 'COMMON.TORSION'
7248       include 'COMMON.VAR'
7249       include 'COMMON.GEO'
7250       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7251       double precision ggg1(3),ggg2(3)
7252 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7253 C                                                                              C
7254 C                            Parallel chains                                   C
7255 C                                                                              C
7256 C          o             o                   o             o                   C
7257 C         /l\           / \             \   / \           / \   /              C
7258 C        /   \         /   \             \ /   \         /   \ /               C
7259 C       j| o |l1       | o |              o| o |         | o |o                C
7260 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7261 C      \i/   \         /   \ /             /   \         /   \                 C
7262 C       o    k1             o                                                  C
7263 C         (I)          (II)                (III)          (IV)                 C
7264 C                                                                              C
7265 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7266 C                                                                              C
7267 C                            Antiparallel chains                               C
7268 C                                                                              C
7269 C          o             o                   o             o                   C
7270 C         /j\           / \             \   / \           / \   /              C
7271 C        /   \         /   \             \ /   \         /   \ /               C
7272 C      j1| o |l        | o |              o| o |         | o |o                C
7273 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7274 C      \i/   \         /   \ /             /   \         /   \                 C
7275 C       o     k1            o                                                  C
7276 C         (I)          (II)                (III)          (IV)                 C
7277 C                                                                              C
7278 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7279 C                                                                              C
7280 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7281 C                                                                              C
7282 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7283 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7284 cd        eello5=0.0d0
7285 cd        return
7286 cd      endif
7287 cd      write (iout,*)
7288 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7289 cd     &   ' and',k,l
7290       itk=itortyp(itype(k))
7291       itl=itortyp(itype(l))
7292       itj=itortyp(itype(j))
7293       eello5_1=0.0d0
7294       eello5_2=0.0d0
7295       eello5_3=0.0d0
7296       eello5_4=0.0d0
7297 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7298 cd     &   eel5_3_num,eel5_4_num)
7299       do iii=1,2
7300         do kkk=1,5
7301           do lll=1,3
7302             derx(lll,kkk,iii)=0.0d0
7303           enddo
7304         enddo
7305       enddo
7306 cd      eij=facont_hb(jj,i)
7307 cd      ekl=facont_hb(kk,k)
7308 cd      ekont=eij*ekl
7309 cd      write (iout,*)'Contacts have occurred for peptide groups',
7310 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7311 cd      goto 1111
7312 C Contribution from the graph I.
7313 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7314 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7315       call transpose2(EUg(1,1,k),auxmat(1,1))
7316       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7317       vv(1)=pizda(1,1)-pizda(2,2)
7318       vv(2)=pizda(1,2)+pizda(2,1)
7319       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7320      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7321 C Explicit gradient in virtual-dihedral angles.
7322       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7323      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7324      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7325       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7326       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7327       vv(1)=pizda(1,1)-pizda(2,2)
7328       vv(2)=pizda(1,2)+pizda(2,1)
7329       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7330      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7331      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7332       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7333       vv(1)=pizda(1,1)-pizda(2,2)
7334       vv(2)=pizda(1,2)+pizda(2,1)
7335       if (l.eq.j+1) then
7336         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7337      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7338      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7339       else
7340         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7341      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7342      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7343       endif
7344 C Cartesian gradient
7345       do iii=1,2
7346         do kkk=1,5
7347           do lll=1,3
7348             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7349      &        pizda(1,1))
7350             vv(1)=pizda(1,1)-pizda(2,2)
7351             vv(2)=pizda(1,2)+pizda(2,1)
7352             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7353      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7354      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7355           enddo
7356         enddo
7357       enddo
7358 c      goto 1112
7359 c1111  continue
7360 C Contribution from graph II
7361       call transpose2(EE(1,1,itk),auxmat(1,1))
7362       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7363       vv(1)=pizda(1,1)+pizda(2,2)
7364       vv(2)=pizda(2,1)-pizda(1,2)
7365       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7366      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7367 C Explicit gradient in virtual-dihedral angles.
7368       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7369      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7370       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7371       vv(1)=pizda(1,1)+pizda(2,2)
7372       vv(2)=pizda(2,1)-pizda(1,2)
7373       if (l.eq.j+1) then
7374         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7375      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7376      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7377       else
7378         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7379      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7380      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7381       endif
7382 C Cartesian gradient
7383       do iii=1,2
7384         do kkk=1,5
7385           do lll=1,3
7386             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7387      &        pizda(1,1))
7388             vv(1)=pizda(1,1)+pizda(2,2)
7389             vv(2)=pizda(2,1)-pizda(1,2)
7390             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7391      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7392      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7393           enddo
7394         enddo
7395       enddo
7396 cd      goto 1112
7397 cd1111  continue
7398       if (l.eq.j+1) then
7399 cd        goto 1110
7400 C Parallel orientation
7401 C Contribution from graph III
7402         call transpose2(EUg(1,1,l),auxmat(1,1))
7403         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7404         vv(1)=pizda(1,1)-pizda(2,2)
7405         vv(2)=pizda(1,2)+pizda(2,1)
7406         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7407      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7408 C Explicit gradient in virtual-dihedral angles.
7409         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7410      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7411      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7412         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7413         vv(1)=pizda(1,1)-pizda(2,2)
7414         vv(2)=pizda(1,2)+pizda(2,1)
7415         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7416      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7417      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7418         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7419         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7420         vv(1)=pizda(1,1)-pizda(2,2)
7421         vv(2)=pizda(1,2)+pizda(2,1)
7422         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7423      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7424      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7425 C Cartesian gradient
7426         do iii=1,2
7427           do kkk=1,5
7428             do lll=1,3
7429               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7430      &          pizda(1,1))
7431               vv(1)=pizda(1,1)-pizda(2,2)
7432               vv(2)=pizda(1,2)+pizda(2,1)
7433               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7434      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7435      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7436             enddo
7437           enddo
7438         enddo
7439 cd        goto 1112
7440 C Contribution from graph IV
7441 cd1110    continue
7442         call transpose2(EE(1,1,itl),auxmat(1,1))
7443         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7444         vv(1)=pizda(1,1)+pizda(2,2)
7445         vv(2)=pizda(2,1)-pizda(1,2)
7446         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7447      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7448 C Explicit gradient in virtual-dihedral angles.
7449         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7450      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7451         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7452         vv(1)=pizda(1,1)+pizda(2,2)
7453         vv(2)=pizda(2,1)-pizda(1,2)
7454         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7455      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7456      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7457 C Cartesian gradient
7458         do iii=1,2
7459           do kkk=1,5
7460             do lll=1,3
7461               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7462      &          pizda(1,1))
7463               vv(1)=pizda(1,1)+pizda(2,2)
7464               vv(2)=pizda(2,1)-pizda(1,2)
7465               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7466      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7467      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7468             enddo
7469           enddo
7470         enddo
7471       else
7472 C Antiparallel orientation
7473 C Contribution from graph III
7474 c        goto 1110
7475         call transpose2(EUg(1,1,j),auxmat(1,1))
7476         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7477         vv(1)=pizda(1,1)-pizda(2,2)
7478         vv(2)=pizda(1,2)+pizda(2,1)
7479         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7480      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7481 C Explicit gradient in virtual-dihedral angles.
7482         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7483      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7484      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7485         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7486         vv(1)=pizda(1,1)-pizda(2,2)
7487         vv(2)=pizda(1,2)+pizda(2,1)
7488         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7489      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7490      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7491         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7492         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7493         vv(1)=pizda(1,1)-pizda(2,2)
7494         vv(2)=pizda(1,2)+pizda(2,1)
7495         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7496      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7497      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7498 C Cartesian gradient
7499         do iii=1,2
7500           do kkk=1,5
7501             do lll=1,3
7502               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7503      &          pizda(1,1))
7504               vv(1)=pizda(1,1)-pizda(2,2)
7505               vv(2)=pizda(1,2)+pizda(2,1)
7506               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7507      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7508      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7509             enddo
7510           enddo
7511         enddo
7512 cd        goto 1112
7513 C Contribution from graph IV
7514 1110    continue
7515         call transpose2(EE(1,1,itj),auxmat(1,1))
7516         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7517         vv(1)=pizda(1,1)+pizda(2,2)
7518         vv(2)=pizda(2,1)-pizda(1,2)
7519         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7520      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7521 C Explicit gradient in virtual-dihedral angles.
7522         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7523      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7524         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7525         vv(1)=pizda(1,1)+pizda(2,2)
7526         vv(2)=pizda(2,1)-pizda(1,2)
7527         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7528      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7529      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7530 C Cartesian gradient
7531         do iii=1,2
7532           do kkk=1,5
7533             do lll=1,3
7534               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7535      &          pizda(1,1))
7536               vv(1)=pizda(1,1)+pizda(2,2)
7537               vv(2)=pizda(2,1)-pizda(1,2)
7538               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7539      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7540      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7541             enddo
7542           enddo
7543         enddo
7544       endif
7545 1112  continue
7546       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7547 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7548 cd        write (2,*) 'ijkl',i,j,k,l
7549 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7550 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7551 cd      endif
7552 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7553 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7554 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7555 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7556       if (j.lt.nres-1) then
7557         j1=j+1
7558         j2=j-1
7559       else
7560         j1=j-1
7561         j2=j-2
7562       endif
7563       if (l.lt.nres-1) then
7564         l1=l+1
7565         l2=l-1
7566       else
7567         l1=l-1
7568         l2=l-2
7569       endif
7570 cd      eij=1.0d0
7571 cd      ekl=1.0d0
7572 cd      ekont=1.0d0
7573 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7574 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7575 C        summed up outside the subrouine as for the other subroutines
7576 C        handling long-range interactions. The old code is commented out
7577 C        with "cgrad" to keep track of changes.
7578       do ll=1,3
7579 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7580 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7581         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7582         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7583 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7584 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7585 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7586 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7587 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7588 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7589 c     &   gradcorr5ij,
7590 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7591 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7592 cgrad        ghalf=0.5d0*ggg1(ll)
7593 cd        ghalf=0.0d0
7594         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7595         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7596         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7597         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7598         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7599         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7600 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7601 cgrad        ghalf=0.5d0*ggg2(ll)
7602 cd        ghalf=0.0d0
7603         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7604         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7605         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7606         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7607         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7608         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7609       enddo
7610 cd      goto 1112
7611 cgrad      do m=i+1,j-1
7612 cgrad        do ll=1,3
7613 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7614 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7615 cgrad        enddo
7616 cgrad      enddo
7617 cgrad      do m=k+1,l-1
7618 cgrad        do ll=1,3
7619 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7620 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7621 cgrad        enddo
7622 cgrad      enddo
7623 c1112  continue
7624 cgrad      do m=i+2,j2
7625 cgrad        do ll=1,3
7626 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7627 cgrad        enddo
7628 cgrad      enddo
7629 cgrad      do m=k+2,l2
7630 cgrad        do ll=1,3
7631 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7632 cgrad        enddo
7633 cgrad      enddo
7634 cd      do iii=1,nres-3
7635 cd        write (2,*) iii,g_corr5_loc(iii)
7636 cd      enddo
7637       eello5=ekont*eel5
7638 cd      write (2,*) 'ekont',ekont
7639 cd      write (iout,*) 'eello5',ekont*eel5
7640       return
7641       end
7642 c--------------------------------------------------------------------------
7643       double precision function eello6(i,j,k,l,jj,kk)
7644       implicit real*8 (a-h,o-z)
7645       include 'DIMENSIONS'
7646       include 'COMMON.IOUNITS'
7647       include 'COMMON.CHAIN'
7648       include 'COMMON.DERIV'
7649       include 'COMMON.INTERACT'
7650       include 'COMMON.CONTACTS'
7651       include 'COMMON.TORSION'
7652       include 'COMMON.VAR'
7653       include 'COMMON.GEO'
7654       include 'COMMON.FFIELD'
7655       double precision ggg1(3),ggg2(3)
7656 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7657 cd        eello6=0.0d0
7658 cd        return
7659 cd      endif
7660 cd      write (iout,*)
7661 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7662 cd     &   ' and',k,l
7663       eello6_1=0.0d0
7664       eello6_2=0.0d0
7665       eello6_3=0.0d0
7666       eello6_4=0.0d0
7667       eello6_5=0.0d0
7668       eello6_6=0.0d0
7669 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7670 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7671       do iii=1,2
7672         do kkk=1,5
7673           do lll=1,3
7674             derx(lll,kkk,iii)=0.0d0
7675           enddo
7676         enddo
7677       enddo
7678 cd      eij=facont_hb(jj,i)
7679 cd      ekl=facont_hb(kk,k)
7680 cd      ekont=eij*ekl
7681 cd      eij=1.0d0
7682 cd      ekl=1.0d0
7683 cd      ekont=1.0d0
7684       if (l.eq.j+1) then
7685         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7686         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7687         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7688         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7689         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7690         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7691       else
7692         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7693         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7694         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7695         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7696         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7697           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7698         else
7699           eello6_5=0.0d0
7700         endif
7701         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7702       endif
7703 C If turn contributions are considered, they will be handled separately.
7704       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7705 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7706 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7707 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7708 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7709 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7710 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7711 cd      goto 1112
7712       if (j.lt.nres-1) then
7713         j1=j+1
7714         j2=j-1
7715       else
7716         j1=j-1
7717         j2=j-2
7718       endif
7719       if (l.lt.nres-1) then
7720         l1=l+1
7721         l2=l-1
7722       else
7723         l1=l-1
7724         l2=l-2
7725       endif
7726       do ll=1,3
7727 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7728 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7729 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7730 cgrad        ghalf=0.5d0*ggg1(ll)
7731 cd        ghalf=0.0d0
7732         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7733         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7734         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7735         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7736         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7737         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7738         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7739         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7740 cgrad        ghalf=0.5d0*ggg2(ll)
7741 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7742 cd        ghalf=0.0d0
7743         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7744         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7745         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7746         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7747         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7748         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7749       enddo
7750 cd      goto 1112
7751 cgrad      do m=i+1,j-1
7752 cgrad        do ll=1,3
7753 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7754 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7755 cgrad        enddo
7756 cgrad      enddo
7757 cgrad      do m=k+1,l-1
7758 cgrad        do ll=1,3
7759 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7760 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7761 cgrad        enddo
7762 cgrad      enddo
7763 cgrad1112  continue
7764 cgrad      do m=i+2,j2
7765 cgrad        do ll=1,3
7766 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7767 cgrad        enddo
7768 cgrad      enddo
7769 cgrad      do m=k+2,l2
7770 cgrad        do ll=1,3
7771 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7772 cgrad        enddo
7773 cgrad      enddo
7774 cd      do iii=1,nres-3
7775 cd        write (2,*) iii,g_corr6_loc(iii)
7776 cd      enddo
7777       eello6=ekont*eel6
7778 cd      write (2,*) 'ekont',ekont
7779 cd      write (iout,*) 'eello6',ekont*eel6
7780       return
7781       end
7782 c--------------------------------------------------------------------------
7783       double precision function eello6_graph1(i,j,k,l,imat,swap)
7784       implicit real*8 (a-h,o-z)
7785       include 'DIMENSIONS'
7786       include 'COMMON.IOUNITS'
7787       include 'COMMON.CHAIN'
7788       include 'COMMON.DERIV'
7789       include 'COMMON.INTERACT'
7790       include 'COMMON.CONTACTS'
7791       include 'COMMON.TORSION'
7792       include 'COMMON.VAR'
7793       include 'COMMON.GEO'
7794       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7795       logical swap
7796       logical lprn
7797       common /kutas/ lprn
7798 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7799 C
7800 C      Parallel       Antiparallel
7801 C
7802 C          o             o
7803 C         /l\           /j\
7804 C        /   \         /   \
7805 C       /| o |         | o |\
7806 C     \ j|/k\|  /   \  |/k\|l /
7807 C      \ /   \ /     \ /   \ /
7808 C       o     o       o     o
7809 C       i             i
7810 C
7811 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7812       itk=itortyp(itype(k))
7813       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7814       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7815       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7816       call transpose2(EUgC(1,1,k),auxmat(1,1))
7817       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7818       vv1(1)=pizda1(1,1)-pizda1(2,2)
7819       vv1(2)=pizda1(1,2)+pizda1(2,1)
7820       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7821       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7822       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7823       s5=scalar2(vv(1),Dtobr2(1,i))
7824 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7825       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7826       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7827      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7828      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7829      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7830      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7831      & +scalar2(vv(1),Dtobr2der(1,i)))
7832       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7833       vv1(1)=pizda1(1,1)-pizda1(2,2)
7834       vv1(2)=pizda1(1,2)+pizda1(2,1)
7835       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7836       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7837       if (l.eq.j+1) then
7838         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7839      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7840      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7841      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7842      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7843       else
7844         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7845      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7846      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7847      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7848      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7849       endif
7850       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7851       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7852       vv1(1)=pizda1(1,1)-pizda1(2,2)
7853       vv1(2)=pizda1(1,2)+pizda1(2,1)
7854       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7855      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7856      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7857      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7858       do iii=1,2
7859         if (swap) then
7860           ind=3-iii
7861         else
7862           ind=iii
7863         endif
7864         do kkk=1,5
7865           do lll=1,3
7866             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7867             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7868             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7869             call transpose2(EUgC(1,1,k),auxmat(1,1))
7870             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7871      &        pizda1(1,1))
7872             vv1(1)=pizda1(1,1)-pizda1(2,2)
7873             vv1(2)=pizda1(1,2)+pizda1(2,1)
7874             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7875             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7876      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7877             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7878      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7879             s5=scalar2(vv(1),Dtobr2(1,i))
7880             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7881           enddo
7882         enddo
7883       enddo
7884       return
7885       end
7886 c----------------------------------------------------------------------------
7887       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7888       implicit real*8 (a-h,o-z)
7889       include 'DIMENSIONS'
7890       include 'COMMON.IOUNITS'
7891       include 'COMMON.CHAIN'
7892       include 'COMMON.DERIV'
7893       include 'COMMON.INTERACT'
7894       include 'COMMON.CONTACTS'
7895       include 'COMMON.TORSION'
7896       include 'COMMON.VAR'
7897       include 'COMMON.GEO'
7898       logical swap
7899       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7900      & auxvec1(2),auxvec2(1),auxmat1(2,2)
7901       logical lprn
7902       common /kutas/ lprn
7903 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7904 C
7905 C      Parallel       Antiparallel
7906 C
7907 C          o             o
7908 C     \   /l\           /j\   /
7909 C      \ /   \         /   \ /
7910 C       o| o |         | o |o
7911 C     \ j|/k\|      \  |/k\|l
7912 C      \ /   \       \ /   \
7913 C       o             o
7914 C       i             i
7915 C
7916 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7917 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7918 C AL 7/4/01 s1 would occur in the sixth-order moment,
7919 C           but not in a cluster cumulant
7920 #ifdef MOMENT
7921       s1=dip(1,jj,i)*dip(1,kk,k)
7922 #endif
7923       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7924       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7925       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7926       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7927       call transpose2(EUg(1,1,k),auxmat(1,1))
7928       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7929       vv(1)=pizda(1,1)-pizda(2,2)
7930       vv(2)=pizda(1,2)+pizda(2,1)
7931       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7932 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7933 #ifdef MOMENT
7934       eello6_graph2=-(s1+s2+s3+s4)
7935 #else
7936       eello6_graph2=-(s2+s3+s4)
7937 #endif
7938 c      eello6_graph2=-s3
7939 C Derivatives in gamma(i-1)
7940       if (i.gt.1) then
7941 #ifdef MOMENT
7942         s1=dipderg(1,jj,i)*dip(1,kk,k)
7943 #endif
7944         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7945         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7946         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7947         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7948 #ifdef MOMENT
7949         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7950 #else
7951         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7952 #endif
7953 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7954       endif
7955 C Derivatives in gamma(k-1)
7956 #ifdef MOMENT
7957       s1=dip(1,jj,i)*dipderg(1,kk,k)
7958 #endif
7959       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7960       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7961       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7962       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7963       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7964       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7965       vv(1)=pizda(1,1)-pizda(2,2)
7966       vv(2)=pizda(1,2)+pizda(2,1)
7967       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7968 #ifdef MOMENT
7969       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7970 #else
7971       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7972 #endif
7973 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7974 C Derivatives in gamma(j-1) or gamma(l-1)
7975       if (j.gt.1) then
7976 #ifdef MOMENT
7977         s1=dipderg(3,jj,i)*dip(1,kk,k)
7978 #endif
7979         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7980         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7981         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7982         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7983         vv(1)=pizda(1,1)-pizda(2,2)
7984         vv(2)=pizda(1,2)+pizda(2,1)
7985         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7986 #ifdef MOMENT
7987         if (swap) then
7988           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7989         else
7990           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7991         endif
7992 #endif
7993         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7994 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7995       endif
7996 C Derivatives in gamma(l-1) or gamma(j-1)
7997       if (l.gt.1) then
7998 #ifdef MOMENT
7999         s1=dip(1,jj,i)*dipderg(3,kk,k)
8000 #endif
8001         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8002         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8003         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8004         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8005         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8006         vv(1)=pizda(1,1)-pizda(2,2)
8007         vv(2)=pizda(1,2)+pizda(2,1)
8008         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8009 #ifdef MOMENT
8010         if (swap) then
8011           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8012         else
8013           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8014         endif
8015 #endif
8016         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8017 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8018       endif
8019 C Cartesian derivatives.
8020       if (lprn) then
8021         write (2,*) 'In eello6_graph2'
8022         do iii=1,2
8023           write (2,*) 'iii=',iii
8024           do kkk=1,5
8025             write (2,*) 'kkk=',kkk
8026             do jjj=1,2
8027               write (2,'(3(2f10.5),5x)')
8028      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8029             enddo
8030           enddo
8031         enddo
8032       endif
8033       do iii=1,2
8034         do kkk=1,5
8035           do lll=1,3
8036 #ifdef MOMENT
8037             if (iii.eq.1) then
8038               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8039             else
8040               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8041             endif
8042 #endif
8043             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8044      &        auxvec(1))
8045             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8046             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8047      &        auxvec(1))
8048             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8049             call transpose2(EUg(1,1,k),auxmat(1,1))
8050             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8051      &        pizda(1,1))
8052             vv(1)=pizda(1,1)-pizda(2,2)
8053             vv(2)=pizda(1,2)+pizda(2,1)
8054             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8055 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8056 #ifdef MOMENT
8057             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8058 #else
8059             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8060 #endif
8061             if (swap) then
8062               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8063             else
8064               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8065             endif
8066           enddo
8067         enddo
8068       enddo
8069       return
8070       end
8071 c----------------------------------------------------------------------------
8072       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8073       implicit real*8 (a-h,o-z)
8074       include 'DIMENSIONS'
8075       include 'COMMON.IOUNITS'
8076       include 'COMMON.CHAIN'
8077       include 'COMMON.DERIV'
8078       include 'COMMON.INTERACT'
8079       include 'COMMON.CONTACTS'
8080       include 'COMMON.TORSION'
8081       include 'COMMON.VAR'
8082       include 'COMMON.GEO'
8083       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8084       logical swap
8085 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8086 C
8087 C      Parallel       Antiparallel
8088 C
8089 C          o             o
8090 C         /l\   /   \   /j\
8091 C        /   \ /     \ /   \
8092 C       /| o |o       o| o |\
8093 C       j|/k\|  /      |/k\|l /
8094 C        /   \ /       /   \ /
8095 C       /     o       /     o
8096 C       i             i
8097 C
8098 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8099 C
8100 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8101 C           energy moment and not to the cluster cumulant.
8102       iti=itortyp(itype(i))
8103       if (j.lt.nres-1) then
8104         itj1=itortyp(itype(j+1))
8105       else
8106         itj1=ntortyp+1
8107       endif
8108       itk=itortyp(itype(k))
8109       itk1=itortyp(itype(k+1))
8110       if (l.lt.nres-1) then
8111         itl1=itortyp(itype(l+1))
8112       else
8113         itl1=ntortyp+1
8114       endif
8115 #ifdef MOMENT
8116       s1=dip(4,jj,i)*dip(4,kk,k)
8117 #endif
8118       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8119       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8120       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8121       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8122       call transpose2(EE(1,1,itk),auxmat(1,1))
8123       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8124       vv(1)=pizda(1,1)+pizda(2,2)
8125       vv(2)=pizda(2,1)-pizda(1,2)
8126       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8127 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8128 cd     & "sum",-(s2+s3+s4)
8129 #ifdef MOMENT
8130       eello6_graph3=-(s1+s2+s3+s4)
8131 #else
8132       eello6_graph3=-(s2+s3+s4)
8133 #endif
8134 c      eello6_graph3=-s4
8135 C Derivatives in gamma(k-1)
8136       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8137       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8138       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8139       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8140 C Derivatives in gamma(l-1)
8141       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8142       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8143       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8144       vv(1)=pizda(1,1)+pizda(2,2)
8145       vv(2)=pizda(2,1)-pizda(1,2)
8146       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8147       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8148 C Cartesian derivatives.
8149       do iii=1,2
8150         do kkk=1,5
8151           do lll=1,3
8152 #ifdef MOMENT
8153             if (iii.eq.1) then
8154               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8155             else
8156               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8157             endif
8158 #endif
8159             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8160      &        auxvec(1))
8161             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8162             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8163      &        auxvec(1))
8164             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8165             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8166      &        pizda(1,1))
8167             vv(1)=pizda(1,1)+pizda(2,2)
8168             vv(2)=pizda(2,1)-pizda(1,2)
8169             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8170 #ifdef MOMENT
8171             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8172 #else
8173             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8174 #endif
8175             if (swap) then
8176               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8177             else
8178               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8179             endif
8180 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8181           enddo
8182         enddo
8183       enddo
8184       return
8185       end
8186 c----------------------------------------------------------------------------
8187       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8188       implicit real*8 (a-h,o-z)
8189       include 'DIMENSIONS'
8190       include 'COMMON.IOUNITS'
8191       include 'COMMON.CHAIN'
8192       include 'COMMON.DERIV'
8193       include 'COMMON.INTERACT'
8194       include 'COMMON.CONTACTS'
8195       include 'COMMON.TORSION'
8196       include 'COMMON.VAR'
8197       include 'COMMON.GEO'
8198       include 'COMMON.FFIELD'
8199       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8200      & auxvec1(2),auxmat1(2,2)
8201       logical swap
8202 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8203 C
8204 C      Parallel       Antiparallel
8205 C
8206 C          o             o
8207 C         /l\   /   \   /j\
8208 C        /   \ /     \ /   \
8209 C       /| o |o       o| o |\
8210 C     \ j|/k\|      \  |/k\|l
8211 C      \ /   \       \ /   \
8212 C       o     \       o     \
8213 C       i             i
8214 C
8215 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8216 C
8217 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8218 C           energy moment and not to the cluster cumulant.
8219 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8220       iti=itortyp(itype(i))
8221       itj=itortyp(itype(j))
8222       if (j.lt.nres-1) then
8223         itj1=itortyp(itype(j+1))
8224       else
8225         itj1=ntortyp+1
8226       endif
8227       itk=itortyp(itype(k))
8228       if (k.lt.nres-1) then
8229         itk1=itortyp(itype(k+1))
8230       else
8231         itk1=ntortyp+1
8232       endif
8233       itl=itortyp(itype(l))
8234       if (l.lt.nres-1) then
8235         itl1=itortyp(itype(l+1))
8236       else
8237         itl1=ntortyp+1
8238       endif
8239 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8240 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8241 cd     & ' itl',itl,' itl1',itl1
8242 #ifdef MOMENT
8243       if (imat.eq.1) then
8244         s1=dip(3,jj,i)*dip(3,kk,k)
8245       else
8246         s1=dip(2,jj,j)*dip(2,kk,l)
8247       endif
8248 #endif
8249       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8250       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8251       if (j.eq.l+1) then
8252         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8253         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8254       else
8255         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8256         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8257       endif
8258       call transpose2(EUg(1,1,k),auxmat(1,1))
8259       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8260       vv(1)=pizda(1,1)-pizda(2,2)
8261       vv(2)=pizda(2,1)+pizda(1,2)
8262       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8263 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8264 #ifdef MOMENT
8265       eello6_graph4=-(s1+s2+s3+s4)
8266 #else
8267       eello6_graph4=-(s2+s3+s4)
8268 #endif
8269 C Derivatives in gamma(i-1)
8270       if (i.gt.1) then
8271 #ifdef MOMENT
8272         if (imat.eq.1) then
8273           s1=dipderg(2,jj,i)*dip(3,kk,k)
8274         else
8275           s1=dipderg(4,jj,j)*dip(2,kk,l)
8276         endif
8277 #endif
8278         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8279         if (j.eq.l+1) then
8280           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8281           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8282         else
8283           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8284           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8285         endif
8286         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8287         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8288 cd          write (2,*) 'turn6 derivatives'
8289 #ifdef MOMENT
8290           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8291 #else
8292           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8293 #endif
8294         else
8295 #ifdef MOMENT
8296           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8297 #else
8298           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8299 #endif
8300         endif
8301       endif
8302 C Derivatives in gamma(k-1)
8303 #ifdef MOMENT
8304       if (imat.eq.1) then
8305         s1=dip(3,jj,i)*dipderg(2,kk,k)
8306       else
8307         s1=dip(2,jj,j)*dipderg(4,kk,l)
8308       endif
8309 #endif
8310       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8311       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8312       if (j.eq.l+1) then
8313         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8314         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8315       else
8316         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8317         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8318       endif
8319       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8320       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8321       vv(1)=pizda(1,1)-pizda(2,2)
8322       vv(2)=pizda(2,1)+pizda(1,2)
8323       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8324       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8325 #ifdef MOMENT
8326         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8327 #else
8328         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8329 #endif
8330       else
8331 #ifdef MOMENT
8332         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8333 #else
8334         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8335 #endif
8336       endif
8337 C Derivatives in gamma(j-1) or gamma(l-1)
8338       if (l.eq.j+1 .and. l.gt.1) then
8339         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8340         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8341         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8342         vv(1)=pizda(1,1)-pizda(2,2)
8343         vv(2)=pizda(2,1)+pizda(1,2)
8344         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8345         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8346       else if (j.gt.1) then
8347         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8348         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8349         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8350         vv(1)=pizda(1,1)-pizda(2,2)
8351         vv(2)=pizda(2,1)+pizda(1,2)
8352         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8353         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8354           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8355         else
8356           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8357         endif
8358       endif
8359 C Cartesian derivatives.
8360       do iii=1,2
8361         do kkk=1,5
8362           do lll=1,3
8363 #ifdef MOMENT
8364             if (iii.eq.1) then
8365               if (imat.eq.1) then
8366                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8367               else
8368                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8369               endif
8370             else
8371               if (imat.eq.1) then
8372                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8373               else
8374                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8375               endif
8376             endif
8377 #endif
8378             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8379      &        auxvec(1))
8380             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8381             if (j.eq.l+1) then
8382               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8383      &          b1(1,itj1),auxvec(1))
8384               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8385             else
8386               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8387      &          b1(1,itl1),auxvec(1))
8388               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8389             endif
8390             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8391      &        pizda(1,1))
8392             vv(1)=pizda(1,1)-pizda(2,2)
8393             vv(2)=pizda(2,1)+pizda(1,2)
8394             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8395             if (swap) then
8396               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8397 #ifdef MOMENT
8398                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8399      &             -(s1+s2+s4)
8400 #else
8401                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8402      &             -(s2+s4)
8403 #endif
8404                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8405               else
8406 #ifdef MOMENT
8407                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8408 #else
8409                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8410 #endif
8411                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8412               endif
8413             else
8414 #ifdef MOMENT
8415               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8416 #else
8417               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8418 #endif
8419               if (l.eq.j+1) then
8420                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8421               else
8422                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8423               endif
8424             endif
8425           enddo
8426         enddo
8427       enddo
8428       return
8429       end
8430 c----------------------------------------------------------------------------
8431       double precision function eello_turn6(i,jj,kk)
8432       implicit real*8 (a-h,o-z)
8433       include 'DIMENSIONS'
8434       include 'COMMON.IOUNITS'
8435       include 'COMMON.CHAIN'
8436       include 'COMMON.DERIV'
8437       include 'COMMON.INTERACT'
8438       include 'COMMON.CONTACTS'
8439       include 'COMMON.TORSION'
8440       include 'COMMON.VAR'
8441       include 'COMMON.GEO'
8442       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8443      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8444      &  ggg1(3),ggg2(3)
8445       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8446      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8447 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8448 C           the respective energy moment and not to the cluster cumulant.
8449       s1=0.0d0
8450       s8=0.0d0
8451       s13=0.0d0
8452 c
8453       eello_turn6=0.0d0
8454       j=i+4
8455       k=i+1
8456       l=i+3
8457       iti=itortyp(itype(i))
8458       itk=itortyp(itype(k))
8459       itk1=itortyp(itype(k+1))
8460       itl=itortyp(itype(l))
8461       itj=itortyp(itype(j))
8462 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8463 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8464 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8465 cd        eello6=0.0d0
8466 cd        return
8467 cd      endif
8468 cd      write (iout,*)
8469 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8470 cd     &   ' and',k,l
8471 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8472       do iii=1,2
8473         do kkk=1,5
8474           do lll=1,3
8475             derx_turn(lll,kkk,iii)=0.0d0
8476           enddo
8477         enddo
8478       enddo
8479 cd      eij=1.0d0
8480 cd      ekl=1.0d0
8481 cd      ekont=1.0d0
8482       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8483 cd      eello6_5=0.0d0
8484 cd      write (2,*) 'eello6_5',eello6_5
8485 #ifdef MOMENT
8486       call transpose2(AEA(1,1,1),auxmat(1,1))
8487       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8488       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8489       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8490 #endif
8491       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8492       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8493       s2 = scalar2(b1(1,itk),vtemp1(1))
8494 #ifdef MOMENT
8495       call transpose2(AEA(1,1,2),atemp(1,1))
8496       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8497       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8498       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8499 #endif
8500       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8501       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8502       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8503 #ifdef MOMENT
8504       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8505       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8506       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8507       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8508       ss13 = scalar2(b1(1,itk),vtemp4(1))
8509       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8510 #endif
8511 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8512 c      s1=0.0d0
8513 c      s2=0.0d0
8514 c      s8=0.0d0
8515 c      s12=0.0d0
8516 c      s13=0.0d0
8517       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8518 C Derivatives in gamma(i+2)
8519       s1d =0.0d0
8520       s8d =0.0d0
8521 #ifdef MOMENT
8522       call transpose2(AEA(1,1,1),auxmatd(1,1))
8523       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8524       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8525       call transpose2(AEAderg(1,1,2),atempd(1,1))
8526       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8527       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8528 #endif
8529       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8530       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8531       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8532 c      s1d=0.0d0
8533 c      s2d=0.0d0
8534 c      s8d=0.0d0
8535 c      s12d=0.0d0
8536 c      s13d=0.0d0
8537       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8538 C Derivatives in gamma(i+3)
8539 #ifdef MOMENT
8540       call transpose2(AEA(1,1,1),auxmatd(1,1))
8541       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8542       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8543       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8544 #endif
8545       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8546       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8547       s2d = scalar2(b1(1,itk),vtemp1d(1))
8548 #ifdef MOMENT
8549       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8550       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8551 #endif
8552       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8553 #ifdef MOMENT
8554       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8555       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8556       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8557 #endif
8558 c      s1d=0.0d0
8559 c      s2d=0.0d0
8560 c      s8d=0.0d0
8561 c      s12d=0.0d0
8562 c      s13d=0.0d0
8563 #ifdef MOMENT
8564       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8565      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8566 #else
8567       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8568      &               -0.5d0*ekont*(s2d+s12d)
8569 #endif
8570 C Derivatives in gamma(i+4)
8571       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8572       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8573       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8574 #ifdef MOMENT
8575       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8576       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8577       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8578 #endif
8579 c      s1d=0.0d0
8580 c      s2d=0.0d0
8581 c      s8d=0.0d0
8582 C      s12d=0.0d0
8583 c      s13d=0.0d0
8584 #ifdef MOMENT
8585       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8586 #else
8587       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8588 #endif
8589 C Derivatives in gamma(i+5)
8590 #ifdef MOMENT
8591       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8592       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8593       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8594 #endif
8595       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8596       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8597       s2d = scalar2(b1(1,itk),vtemp1d(1))
8598 #ifdef MOMENT
8599       call transpose2(AEA(1,1,2),atempd(1,1))
8600       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8601       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8602 #endif
8603       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8604       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8605 #ifdef MOMENT
8606       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8607       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8608       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8609 #endif
8610 c      s1d=0.0d0
8611 c      s2d=0.0d0
8612 c      s8d=0.0d0
8613 c      s12d=0.0d0
8614 c      s13d=0.0d0
8615 #ifdef MOMENT
8616       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8617      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8618 #else
8619       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8620      &               -0.5d0*ekont*(s2d+s12d)
8621 #endif
8622 C Cartesian derivatives
8623       do iii=1,2
8624         do kkk=1,5
8625           do lll=1,3
8626 #ifdef MOMENT
8627             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8628             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8629             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8630 #endif
8631             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8632             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8633      &          vtemp1d(1))
8634             s2d = scalar2(b1(1,itk),vtemp1d(1))
8635 #ifdef MOMENT
8636             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8637             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8638             s8d = -(atempd(1,1)+atempd(2,2))*
8639      &           scalar2(cc(1,1,itl),vtemp2(1))
8640 #endif
8641             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8642      &           auxmatd(1,1))
8643             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8644             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8645 c      s1d=0.0d0
8646 c      s2d=0.0d0
8647 c      s8d=0.0d0
8648 c      s12d=0.0d0
8649 c      s13d=0.0d0
8650 #ifdef MOMENT
8651             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8652      &        - 0.5d0*(s1d+s2d)
8653 #else
8654             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8655      &        - 0.5d0*s2d
8656 #endif
8657 #ifdef MOMENT
8658             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8659      &        - 0.5d0*(s8d+s12d)
8660 #else
8661             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8662      &        - 0.5d0*s12d
8663 #endif
8664           enddo
8665         enddo
8666       enddo
8667 #ifdef MOMENT
8668       do kkk=1,5
8669         do lll=1,3
8670           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8671      &      achuj_tempd(1,1))
8672           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8673           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8674           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8675           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8676           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8677      &      vtemp4d(1))
8678           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8679           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8680           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8681         enddo
8682       enddo
8683 #endif
8684 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8685 cd     &  16*eel_turn6_num
8686 cd      goto 1112
8687       if (j.lt.nres-1) then
8688         j1=j+1
8689         j2=j-1
8690       else
8691         j1=j-1
8692         j2=j-2
8693       endif
8694       if (l.lt.nres-1) then
8695         l1=l+1
8696         l2=l-1
8697       else
8698         l1=l-1
8699         l2=l-2
8700       endif
8701       do ll=1,3
8702 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8703 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8704 cgrad        ghalf=0.5d0*ggg1(ll)
8705 cd        ghalf=0.0d0
8706         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8707         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8708         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8709      &    +ekont*derx_turn(ll,2,1)
8710         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8711         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8712      &    +ekont*derx_turn(ll,4,1)
8713         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8714         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8715         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8716 cgrad        ghalf=0.5d0*ggg2(ll)
8717 cd        ghalf=0.0d0
8718         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8719      &    +ekont*derx_turn(ll,2,2)
8720         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8721         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8722      &    +ekont*derx_turn(ll,4,2)
8723         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8724         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8725         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8726       enddo
8727 cd      goto 1112
8728 cgrad      do m=i+1,j-1
8729 cgrad        do ll=1,3
8730 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8731 cgrad        enddo
8732 cgrad      enddo
8733 cgrad      do m=k+1,l-1
8734 cgrad        do ll=1,3
8735 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8736 cgrad        enddo
8737 cgrad      enddo
8738 cgrad1112  continue
8739 cgrad      do m=i+2,j2
8740 cgrad        do ll=1,3
8741 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8742 cgrad        enddo
8743 cgrad      enddo
8744 cgrad      do m=k+2,l2
8745 cgrad        do ll=1,3
8746 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8747 cgrad        enddo
8748 cgrad      enddo
8749 cd      do iii=1,nres-3
8750 cd        write (2,*) iii,g_corr6_loc(iii)
8751 cd      enddo
8752       eello_turn6=ekont*eel_turn6
8753 cd      write (2,*) 'ekont',ekont
8754 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8755       return
8756       end
8757
8758 C-----------------------------------------------------------------------------
8759       double precision function scalar(u,v)
8760 !DIR$ INLINEALWAYS scalar
8761 #ifndef OSF
8762 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8763 #endif
8764       implicit none
8765       double precision u(3),v(3)
8766 cd      double precision sc
8767 cd      integer i
8768 cd      sc=0.0d0
8769 cd      do i=1,3
8770 cd        sc=sc+u(i)*v(i)
8771 cd      enddo
8772 cd      scalar=sc
8773
8774       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8775       return
8776       end
8777 crc-------------------------------------------------
8778       SUBROUTINE MATVEC2(A1,V1,V2)
8779 !DIR$ INLINEALWAYS MATVEC2
8780 #ifndef OSF
8781 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8782 #endif
8783       implicit real*8 (a-h,o-z)
8784       include 'DIMENSIONS'
8785       DIMENSION A1(2,2),V1(2),V2(2)
8786 c      DO 1 I=1,2
8787 c        VI=0.0
8788 c        DO 3 K=1,2
8789 c    3     VI=VI+A1(I,K)*V1(K)
8790 c        Vaux(I)=VI
8791 c    1 CONTINUE
8792
8793       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8794       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8795
8796       v2(1)=vaux1
8797       v2(2)=vaux2
8798       END
8799 C---------------------------------------
8800       SUBROUTINE MATMAT2(A1,A2,A3)
8801 #ifndef OSF
8802 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8803 #endif
8804       implicit real*8 (a-h,o-z)
8805       include 'DIMENSIONS'
8806       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8807 c      DIMENSION AI3(2,2)
8808 c        DO  J=1,2
8809 c          A3IJ=0.0
8810 c          DO K=1,2
8811 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8812 c          enddo
8813 c          A3(I,J)=A3IJ
8814 c       enddo
8815 c      enddo
8816
8817       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8818       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8819       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8820       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8821
8822       A3(1,1)=AI3_11
8823       A3(2,1)=AI3_21
8824       A3(1,2)=AI3_12
8825       A3(2,2)=AI3_22
8826       END
8827
8828 c-------------------------------------------------------------------------
8829       double precision function scalar2(u,v)
8830 !DIR$ INLINEALWAYS scalar2
8831       implicit none
8832       double precision u(2),v(2)
8833       double precision sc
8834       integer i
8835       scalar2=u(1)*v(1)+u(2)*v(2)
8836       return
8837       end
8838
8839 C-----------------------------------------------------------------------------
8840
8841       subroutine transpose2(a,at)
8842 !DIR$ INLINEALWAYS transpose2
8843 #ifndef OSF
8844 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8845 #endif
8846       implicit none
8847       double precision a(2,2),at(2,2)
8848       at(1,1)=a(1,1)
8849       at(1,2)=a(2,1)
8850       at(2,1)=a(1,2)
8851       at(2,2)=a(2,2)
8852       return
8853       end
8854 c--------------------------------------------------------------------------
8855       subroutine transpose(n,a,at)
8856       implicit none
8857       integer n,i,j
8858       double precision a(n,n),at(n,n)
8859       do i=1,n
8860         do j=1,n
8861           at(j,i)=a(i,j)
8862         enddo
8863       enddo
8864       return
8865       end
8866 C---------------------------------------------------------------------------
8867       subroutine prodmat3(a1,a2,kk,transp,prod)
8868 !DIR$ INLINEALWAYS prodmat3
8869 #ifndef OSF
8870 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8871 #endif
8872       implicit none
8873       integer i,j
8874       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8875       logical transp
8876 crc      double precision auxmat(2,2),prod_(2,2)
8877
8878       if (transp) then
8879 crc        call transpose2(kk(1,1),auxmat(1,1))
8880 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8881 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8882
8883            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8884      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8885            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8886      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8887            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8888      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8889            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8890      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8891
8892       else
8893 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8894 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8895
8896            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8897      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8898            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8899      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8900            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8901      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8902            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8903      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8904
8905       endif
8906 c      call transpose2(a2(1,1),a2t(1,1))
8907
8908 crc      print *,transp
8909 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8910 crc      print *,((prod(i,j),i=1,2),j=1,2)
8911
8912       return
8913       end
8914