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