source/unres/src_MD-M/energy_p_new_barrier.F.safe

   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       call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 530      &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 531       time_reduce=time_reduce+MPI_Wtime()-time00
 532 #ifdef DEBUG
 533       write (iout,*) "gradbufc_sum after allreduce"
 534       do i=1,nres
 535         write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 536       enddo
 537       call flush(iout)
 538 #endif
 539 #ifdef TIMING
 540       time_allreduce=time_allreduce+MPI_Wtime()-time00
 541 #endif
 542       do i=nnt,nres
 543         do k=1,3
 544           gradbufc(k,i)=0.0d0
 545         enddo
 546       enddo
 547 #ifdef DEBUG
 548       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 549       write (iout,*) (i," jgrad_start",jgrad_start(i),
 550      &                  " jgrad_end  ",jgrad_end(i),
 551      &                  i=igrad_start,igrad_end)
 552 #endif
 553 c
 554 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 555 c do not parallelize this part.
 556 c
 557 c      do i=igrad_start,igrad_end
 558 c        do j=jgrad_start(i),jgrad_end(i)
 559 c          do k=1,3
 560 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 561 c          enddo
 562 c        enddo
 563 c      enddo
 564       do j=1,3
 565         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 566       enddo
 567       do i=nres-2,nnt,-1
 568         do j=1,3
 569           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 570         enddo
 571       enddo
 572 #ifdef DEBUG
 573       write (iout,*) "gradbufc after summing"
 574       do i=1,nres
 575         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 576       enddo
 577       call flush(iout)
 578 #endif
 579       else
 580 #endif
 581 #ifdef DEBUG
 582       write (iout,*) "gradbufc"
 583       do i=1,nres
 584         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 585       enddo
 586       call flush(iout)
 587 #endif
 588       do i=1,nres
 589         do j=1,3
 590           gradbufc_sum(j,i)=gradbufc(j,i)
 591           gradbufc(j,i)=0.0d0
 592         enddo
 593       enddo
 594       do j=1,3
 595         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 596       enddo
 597       do i=nres-2,nnt,-1
 598         do j=1,3
 599           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 600         enddo
 601       enddo
 602 c      do i=nnt,nres-1
 603 c        do k=1,3
 604 c          gradbufc(k,i)=0.0d0
 605 c        enddo
 606 c        do j=i+1,nres
 607 c          do k=1,3
 608 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 609 c          enddo
 610 c        enddo
 611 c      enddo
 612 #ifdef DEBUG
 613       write (iout,*) "gradbufc after summing"
 614       do i=1,nres
 615         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 616       enddo
 617       call flush(iout)
 618 #endif
 619 #ifdef MPI
 620       endif
 621 #endif
 622       do k=1,3
 623         gradbufc(k,nres)=0.0d0
 624       enddo
 625       do i=1,nct
 626         do j=1,3
 627 #ifdef SPLITELE
 628 c          gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 629           gradc(j,i,icg)=welec*gelc(j,i)+
 630      &                wel_loc*gel_loc(j,i)+
 631      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 632      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 633      &                wel_loc*gel_loc_long(j,i)+
 634      &                wcorr*gradcorr_long(j,i)+
 635      &                wcorr5*gradcorr5_long(j,i)+
 636      &                wcorr6*gradcorr6_long(j,i)+
 637      &                wturn6*gcorr6_turn_long(j,i))+
 638      &                wbond*gradb(j,i)+
 639      &                wcorr*gradcorr(j,i)+
 640      &                wturn3*gcorr3_turn(j,i)+
 641      &                wturn4*gcorr4_turn(j,i)+
 642      &                wcorr5*gradcorr5(j,i)+
 643      &                wcorr6*gradcorr6(j,i)+
 644      &                wturn6*gcorr6_turn(j,i)+
 645      &                wsccor*gsccorc(j,i)
 646      &               +wscloc*gscloc(j,i)
 647 #else
 648 c          gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 649           gradc(j,i,icg)=welec*gelc(j,i)+
 650      &                wel_loc*gel_loc(j,i)+
 651      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 652      &                welec*gelc_long(j,i)
 653      &                wel_loc*gel_loc_long(j,i)+
 654      &                wcorr*gcorr_long(j,i)+
 655      &                wcorr5*gradcorr5_long(j,i)+
 656      &                wcorr6*gradcorr6_long(j,i)+
 657      &                wturn6*gcorr6_turn_long(j,i))+
 658      &                wbond*gradb(j,i)+
 659      &                wcorr*gradcorr(j,i)+
 660      &                wturn3*gcorr3_turn(j,i)+
 661      &                wturn4*gcorr4_turn(j,i)+
 662      &                wcorr5*gradcorr5(j,i)+
 663      &                wcorr6*gradcorr6(j,i)+
 664      &                wturn6*gcorr6_turn(j,i)+
 665      &                wsccor*gsccorc(j,i)
 666      &               +wscloc*gscloc(j,i)
 667 #endif
 668           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 669      &                  wbond*gradbx(j,i)+
 670      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 671      &                  wsccor*gsccorx(j,i)
 672      &                 +wscloc*gsclocx(j,i)
 673         enddo
 674       enddo
 675 #ifdef DEBUG
 676       write (iout,*) "gloc before adding corr"
 677       do i=1,4*nres
 678         write (iout,*) i,gloc(i,icg)
 679       enddo
 680 #endif
 681       do i=1,nres-3
 682         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 683      &   +wcorr5*g_corr5_loc(i)
 684      &   +wcorr6*g_corr6_loc(i)
 685      &   +wturn4*gel_loc_turn4(i)
 686      &   +wturn3*gel_loc_turn3(i)
 687      &   +wturn6*gel_loc_turn6(i)
 688      &   +wel_loc*gel_loc_loc(i)
 689      &   +wsccor*gsccor_loc(i)
 690       enddo
 691 #ifdef DEBUG
 692       write (iout,*) "gloc after adding corr"
 693       do i=1,4*nres
 694         write (iout,*) i,gloc(i,icg)
 695       enddo
 696 #endif
 697 #ifdef MPI
 698       if (nfgtasks.gt.1) then
 699         do j=1,3
 700           do i=1,nres
 701             gradbufc_sum(j,i)=gradc(j,i,icg)
 702             gradbufx(j,i)=gradx(j,i,icg)
 703           enddo
 704         enddo
 705         do i=1,4*nres
 706           glocbuf(i)=gloc(i,icg)
 707         enddo
 708         time00=MPI_Wtime()
 709         call MPI_Barrier(FG_COMM,IERR)
 710         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 711         time00=MPI_Wtime()
 712         call MPI_Reduce(gradbufc_sum(1,1),gradc(1,1,icg),3*nres,
 713      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 714         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 715      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 716         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 717      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 718         time_reduce=time_reduce+MPI_Wtime()-time00
 719 #ifdef DEBUG
 720       write (iout,*) "gloc after reduce"
 721       do i=1,4*nres
 722         write (iout,*) i,gloc(i,icg)
 723       enddo
 724 #endif
 725       endif
 726 #endif
 727       do i=1,nres
 728         do j=1,3
 729           gradc(j,i,icg)=gradc(j,i,icg)+gradbufc(j,i)
 730         enddo
 731       enddo
 732       if (gnorm_check) then
 733 c
 734 c Compute the maximum elements of the gradient
 735 c
 736       gvdwc_max=0.0d0
 737       gvdwc_scp_max=0.0d0
 738       gelc_max=0.0d0
 739       gvdwpp_max=0.0d0
 740       gradb_max=0.0d0
 741       ghpbc_max=0.0d0
 742       gradcorr_max=0.0d0
 743       gel_loc_max=0.0d0
 744       gcorr3_turn_max=0.0d0
 745       gcorr4_turn_max=0.0d0
 746       gradcorr5_max=0.0d0
 747       gradcorr6_max=0.0d0
 748       gcorr6_turn_max=0.0d0
 749       gsccorc_max=0.0d0
 750       gscloc_max=0.0d0
 751       gvdwx_max=0.0d0
 752       gradx_scp_max=0.0d0
 753       ghpbx_max=0.0d0
 754       gradxorr_max=0.0d0
 755       gsccorx_max=0.0d0
 756       gsclocx_max=0.0d0
 757       do i=1,nct
 758         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 759         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 760         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 761         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 762      &   gvdwc_scp_max=gvdwc_scp_norm
 763         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 764         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 765         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 766         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 767         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 768         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 769         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 770         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 771         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 772         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 773         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 774         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 775         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 776      &    gcorr3_turn(1,i)))
 777         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 778      &    gcorr3_turn_max=gcorr3_turn_norm
 779         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 780      &    gcorr4_turn(1,i)))
 781         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 782      &    gcorr4_turn_max=gcorr4_turn_norm
 783         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 784         if (gradcorr5_norm.gt.gradcorr5_max)
 785      &    gradcorr5_max=gradcorr5_norm
 786         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 787         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 788         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 789      &    gcorr6_turn(1,i)))
 790         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 791      &    gcorr6_turn_max=gcorr6_turn_norm
 792         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 793         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 794         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 795         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 796         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 797         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 798         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 799         if (gradx_scp_norm.gt.gradx_scp_max)
 800      &    gradx_scp_max=gradx_scp_norm
 801         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 802         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 803         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 804         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 805         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 806         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 807         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 808         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 809       enddo
 810       if (gradout) then
 811 #ifdef AIX
 812         open(istat,file=statname,position="append")
 813 #else
 814         open(istat,file=statname,access="append")
 815 #endif
 816         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 817      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 818      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 819      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 820      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 821      &     gsccorx_max,gsclocx_max
 822         close(istat)
 823         if (gvdwc_max.gt.1.0d4) then
 824           write (iout,*) "gvdwc gvdwx gradb gradbx"
 825           do i=nnt,nct
 826             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 827      &        gradb(j,i),gradbx(j,i),j=1,3)
 828           enddo
 829           call pdbout(0.0d0,'cipiszcze',iout)
 830           call flush(iout)
 831         endif
 832       endif
 833       endif
 834 #ifdef DEBUG
 835       write (iout,*) "gradc gradx gloc"
 836       do i=1,nres
 837         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 838      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 839       enddo
 840 #endif
 841 #ifdef TIMING
 842       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 843 #endif
 844       return
 845       end
 846 c-------------------------------------------------------------------------------
 847       subroutine rescale_weights(t_bath)
 848       implicit real*8 (a-h,o-z)
 849       include 'DIMENSIONS'
 850       include 'COMMON.IOUNITS'
 851       include 'COMMON.FFIELD'
 852       include 'COMMON.SBRIDGE'
 853       double precision kfac /2.4d0/
 854       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 855 c      facT=temp0/t_bath
 856 c      facT=2*temp0/(t_bath+temp0)
 857       if (rescale_mode.eq.0) then
 858         facT=1.0d0
 859         facT2=1.0d0
 860         facT3=1.0d0
 861         facT4=1.0d0
 862         facT5=1.0d0
 863       else if (rescale_mode.eq.1) then
 864         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 865         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 866         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 867         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 868         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 869       else if (rescale_mode.eq.2) then
 870         x=t_bath/temp0
 871         x2=x*x
 872         x3=x2*x
 873         x4=x3*x
 874         x5=x4*x
 875         facT=licznik/dlog(dexp(x)+dexp(-x))
 876         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 877         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 878         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 879         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 880       else
 881         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 882         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 883 #ifdef MPI
 884        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 885 #endif
 886        stop 555
 887       endif
 888       welec=weights(3)*fact
 889       wcorr=weights(4)*fact3
 890       wcorr5=weights(5)*fact4
 891       wcorr6=weights(6)*fact5
 892       wel_loc=weights(7)*fact2
 893       wturn3=weights(8)*fact2
 894       wturn4=weights(9)*fact3
 895       wturn6=weights(10)*fact5
 896       wtor=weights(13)*fact
 897       wtor_d=weights(14)*fact2
 898       wsccor=weights(21)*fact
 899
 900       return
 901       end
 902 C------------------------------------------------------------------------
 903       subroutine enerprint(energia)
 904       implicit real*8 (a-h,o-z)
 905       include 'DIMENSIONS'
 906       include 'COMMON.IOUNITS'
 907       include 'COMMON.FFIELD'
 908       include 'COMMON.SBRIDGE'
 909       include 'COMMON.MD'
 910       double precision energia(0:n_ene)
 911       etot=energia(0)
 912       evdw=energia(1)
 913       evdw2=energia(2)
 914 #ifdef SCP14
 915       evdw2=energia(2)+energia(18)
 916 #else
 917       evdw2=energia(2)
 918 #endif
 919       ees=energia(3)
 920 #ifdef SPLITELE
 921       evdw1=energia(16)
 922 #endif
 923       ecorr=energia(4)
 924       ecorr5=energia(5)
 925       ecorr6=energia(6)
 926       eel_loc=energia(7)
 927       eello_turn3=energia(8)
 928       eello_turn4=energia(9)
 929       eello_turn6=energia(10)
 930       ebe=energia(11)
 931       escloc=energia(12)
 932       etors=energia(13)
 933       etors_d=energia(14)
 934       ehpb=energia(15)
 935       edihcnstr=energia(19)
 936       estr=energia(17)
 937       Uconst=energia(20)
 938       esccor=energia(21)
 939 #ifdef SPLITELE
 940       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 941      &  estr,wbond,ebe,wang,
 942      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 943      &  ecorr,wcorr,
 944      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 945      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 946      &  edihcnstr,ebr*nss,
 947      &  Uconst,etot
 948    10 format (/'Virtual-chain energies:'//
 949      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 950      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 951      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 952      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 953      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 954      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 955      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 956      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 957      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 958      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 959      & ' (SS bridges & dist. cnstr.)'/
 960      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 961      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 962      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 963      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 964      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 965      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 966      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 967      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 968      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 969      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 970      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 971      & 'ETOT=  ',1pE16.6,' (total)')
 972 #else
 973       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 974      &  estr,wbond,ebe,wang,
 975      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 976      &  ecorr,wcorr,
 977      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 978      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 979      &  ebr*nss,Uconst,etot
 980    10 format (/'Virtual-chain energies:'//
 981      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 982      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 983      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 984      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 985      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 986      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 987      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 988      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 989      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 990      & ' (SS bridges & dist. cnstr.)'/
 991      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 992      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 993      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 994      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 995      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 996      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 997      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 998      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 999      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1000      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1001      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1002      & 'ETOT=  ',1pE16.6,' (total)')
1003 #endif
1004       return
1005       end
1006 C-----------------------------------------------------------------------
1007       subroutine elj(evdw)
1008 C
1009 C This subroutine calculates the interaction energy of nonbonded side chains
1010 C assuming the LJ potential of interaction.
1011 C
1012       implicit real*8 (a-h,o-z)
1013       include 'DIMENSIONS'
1014       parameter (accur=1.0d-10)
1015       include 'COMMON.GEO'
1016       include 'COMMON.VAR'
1017       include 'COMMON.LOCAL'
1018       include 'COMMON.CHAIN'
1019       include 'COMMON.DERIV'
1020       include 'COMMON.INTERACT'
1021       include 'COMMON.TORSION'
1022       include 'COMMON.SBRIDGE'
1023       include 'COMMON.NAMES'
1024       include 'COMMON.IOUNITS'
1025       include 'COMMON.CONTACTS'
1026       dimension gg(3)
1027 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1028       evdw=0.0D0
1029       do i=iatsc_s,iatsc_e
1030         itypi=itype(i)
1031         if (itypi.eq.21) cycle
1032         itypi1=itype(i+1)
1033         xi=c(1,nres+i)
1034         yi=c(2,nres+i)
1035         zi=c(3,nres+i)
1036 C Change 12/1/95
1037         num_conti=0
1038 C
1039 C Calculate SC interaction energy.
1040 C
1041         do iint=1,nint_gr(i)
1042 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1043 cd   &                  'iend=',iend(i,iint)
1044           do j=istart(i,iint),iend(i,iint)
1045             itypj=itype(j)
1046             if (itypj.eq.21) cycle
1047             xj=c(1,nres+j)-xi
1048             yj=c(2,nres+j)-yi
1049             zj=c(3,nres+j)-zi
1050 C Change 12/1/95 to calculate four-body interactions
1051             rij=xj*xj+yj*yj+zj*zj
1052             rrij=1.0D0/rij
1053 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1054             eps0ij=eps(itypi,itypj)
1055             fac=rrij**expon2
1056             e1=fac*fac*aa(itypi,itypj)
1057             e2=fac*bb(itypi,itypj)
1058             evdwij=e1+e2
1059 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1060 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1061 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1062 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1063 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1064 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1065             evdw=evdw+evdwij
1066 C
1067 C Calculate the components of the gradient in DC and X
1068 C
1069             fac=-rrij*(e1+evdwij)
1070             gg(1)=xj*fac
1071             gg(2)=yj*fac
1072             gg(3)=zj*fac
1073             do k=1,3
1074               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1075               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1076               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1077               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1078             enddo
1079 cgrad            do k=i,j-1
1080 cgrad              do l=1,3
1081 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1082 cgrad              enddo
1083 cgrad            enddo
1084 C
1085 C 12/1/95, revised on 5/20/97
1086 C
1087 C Calculate the contact function. The ith column of the array JCONT will
1088 C contain the numbers of atoms that make contacts with the atom I (of numbers
1089 C greater than I). The arrays FACONT and GACONT will contain the values of
1090 C the contact function and its derivative.
1091 C
1092 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1093 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1094 C Uncomment next line, if the correlation interactions are contact function only
1095             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1096               rij=dsqrt(rij)
1097               sigij=sigma(itypi,itypj)
1098               r0ij=rs0(itypi,itypj)
1099 C
1100 C Check whether the SC's are not too far to make a contact.
1101 C
1102               rcut=1.5d0*r0ij
1103               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1104 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1105 C
1106               if (fcont.gt.0.0D0) then
1107 C If the SC-SC distance if close to sigma, apply spline.
1108 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1109 cAdam &             fcont1,fprimcont1)
1110 cAdam           fcont1=1.0d0-fcont1
1111 cAdam           if (fcont1.gt.0.0d0) then
1112 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1113 cAdam             fcont=fcont*fcont1
1114 cAdam           endif
1115 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1116 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1117 cga             do k=1,3
1118 cga               gg(k)=gg(k)*eps0ij
1119 cga             enddo
1120 cga             eps0ij=-evdwij*eps0ij
1121 C Uncomment for AL's type of SC correlation interactions.
1122 cadam           eps0ij=-evdwij
1123                 num_conti=num_conti+1
1124                 jcont(num_conti,i)=j
1125                 facont(num_conti,i)=fcont*eps0ij
1126                 fprimcont=eps0ij*fprimcont/rij
1127                 fcont=expon*fcont
1128 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1129 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1130 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1131 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1132                 gacont(1,num_conti,i)=-fprimcont*xj
1133                 gacont(2,num_conti,i)=-fprimcont*yj
1134                 gacont(3,num_conti,i)=-fprimcont*zj
1135 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1136 cd              write (iout,'(2i3,3f10.5)')
1137 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1138               endif
1139             endif
1140           enddo      ! j
1141         enddo        ! iint
1142 C Change 12/1/95
1143         num_cont(i)=num_conti
1144       enddo          ! i
1145       do i=1,nct
1146         do j=1,3
1147           gvdwc(j,i)=expon*gvdwc(j,i)
1148           gvdwx(j,i)=expon*gvdwx(j,i)
1149         enddo
1150       enddo
1151 C******************************************************************************
1152 C
1153 C                              N O T E !!!
1154 C
1155 C To save time, the factor of EXPON has been extracted from ALL components
1156 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1157 C use!
1158 C
1159 C******************************************************************************
1160       return
1161       end
1162 C-----------------------------------------------------------------------------
1163       subroutine eljk(evdw)
1164 C
1165 C This subroutine calculates the interaction energy of nonbonded side chains
1166 C assuming the LJK potential of interaction.
1167 C
1168       implicit real*8 (a-h,o-z)
1169       include 'DIMENSIONS'
1170       include 'COMMON.GEO'
1171       include 'COMMON.VAR'
1172       include 'COMMON.LOCAL'
1173       include 'COMMON.CHAIN'
1174       include 'COMMON.DERIV'
1175       include 'COMMON.INTERACT'
1176       include 'COMMON.IOUNITS'
1177       include 'COMMON.NAMES'
1178       dimension gg(3)
1179       logical scheck
1180 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1181       evdw=0.0D0
1182       do i=iatsc_s,iatsc_e
1183         itypi=itype(i)
1184         if (itypi.eq.21) cycle
1185         itypi1=itype(i+1)
1186         xi=c(1,nres+i)
1187         yi=c(2,nres+i)
1188         zi=c(3,nres+i)
1189 C
1190 C Calculate SC interaction energy.
1191 C
1192         do iint=1,nint_gr(i)
1193           do j=istart(i,iint),iend(i,iint)
1194             itypj=itype(j)
1195             if (itypj.eq.21) cycle
1196             xj=c(1,nres+j)-xi
1197             yj=c(2,nres+j)-yi
1198             zj=c(3,nres+j)-zi
1199             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1200             fac_augm=rrij**expon
1201             e_augm=augm(itypi,itypj)*fac_augm
1202             r_inv_ij=dsqrt(rrij)
1203             rij=1.0D0/r_inv_ij
1204             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1205             fac=r_shift_inv**expon
1206             e1=fac*fac*aa(itypi,itypj)
1207             e2=fac*bb(itypi,itypj)
1208             evdwij=e_augm+e1+e2
1209 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1210 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1211 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1212 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1213 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1214 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1215 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1216             evdw=evdw+evdwij
1217 C
1218 C Calculate the components of the gradient in DC and X
1219 C
1220             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1221             gg(1)=xj*fac
1222             gg(2)=yj*fac
1223             gg(3)=zj*fac
1224             do k=1,3
1225               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1226               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1227               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1228               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1229             enddo
1230 cgrad            do k=i,j-1
1231 cgrad              do l=1,3
1232 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1233 cgrad              enddo
1234 cgrad            enddo
1235           enddo      ! j
1236         enddo        ! iint
1237       enddo          ! i
1238       do i=1,nct
1239         do j=1,3
1240           gvdwc(j,i)=expon*gvdwc(j,i)
1241           gvdwx(j,i)=expon*gvdwx(j,i)
1242         enddo
1243       enddo
1244       return
1245       end
1246 C-----------------------------------------------------------------------------
1247       subroutine ebp(evdw)
1248 C
1249 C This subroutine calculates the interaction energy of nonbonded side chains
1250 C assuming the Berne-Pechukas potential of interaction.
1251 C
1252       implicit real*8 (a-h,o-z)
1253       include 'DIMENSIONS'
1254       include 'COMMON.GEO'
1255       include 'COMMON.VAR'
1256       include 'COMMON.LOCAL'
1257       include 'COMMON.CHAIN'
1258       include 'COMMON.DERIV'
1259       include 'COMMON.NAMES'
1260       include 'COMMON.INTERACT'
1261       include 'COMMON.IOUNITS'
1262       include 'COMMON.CALC'
1263       common /srutu/ icall
1264 c     double precision rrsave(maxdim)
1265       logical lprn
1266       evdw=0.0D0
1267 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1268       evdw=0.0D0
1269 c     if (icall.eq.0) then
1270 c       lprn=.true.
1271 c     else
1272         lprn=.false.
1273 c     endif
1274       ind=0
1275       do i=iatsc_s,iatsc_e
1276         itypi=itype(i)
1277         if (itypi.eq.21) cycle
1278         itypi1=itype(i+1)
1279         xi=c(1,nres+i)
1280         yi=c(2,nres+i)
1281         zi=c(3,nres+i)
1282         dxi=dc_norm(1,nres+i)
1283         dyi=dc_norm(2,nres+i)
1284         dzi=dc_norm(3,nres+i)
1285 c        dsci_inv=dsc_inv(itypi)
1286         dsci_inv=vbld_inv(i+nres)
1287 C
1288 C Calculate SC interaction energy.
1289 C
1290         do iint=1,nint_gr(i)
1291           do j=istart(i,iint),iend(i,iint)
1292             ind=ind+1
1293             itypj=itype(j)
1294             if (itypj.eq.21) cycle
1295 c            dscj_inv=dsc_inv(itypj)
1296             dscj_inv=vbld_inv(j+nres)
1297             chi1=chi(itypi,itypj)
1298             chi2=chi(itypj,itypi)
1299             chi12=chi1*chi2
1300             chip1=chip(itypi)
1301             chip2=chip(itypj)
1302             chip12=chip1*chip2
1303             alf1=alp(itypi)
1304             alf2=alp(itypj)
1305             alf12=0.5D0*(alf1+alf2)
1306 C For diagnostics only!!!
1307 c           chi1=0.0D0
1308 c           chi2=0.0D0
1309 c           chi12=0.0D0
1310 c           chip1=0.0D0
1311 c           chip2=0.0D0
1312 c           chip12=0.0D0
1313 c           alf1=0.0D0
1314 c           alf2=0.0D0
1315 c           alf12=0.0D0
1316             xj=c(1,nres+j)-xi
1317             yj=c(2,nres+j)-yi
1318             zj=c(3,nres+j)-zi
1319             dxj=dc_norm(1,nres+j)
1320             dyj=dc_norm(2,nres+j)
1321             dzj=dc_norm(3,nres+j)
1322             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1323 cd          if (icall.eq.0) then
1324 cd            rrsave(ind)=rrij
1325 cd          else
1326 cd            rrij=rrsave(ind)
1327 cd          endif
1328             rij=dsqrt(rrij)
1329 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1330             call sc_angular
1331 C Calculate whole angle-dependent part of epsilon and contributions
1332 C to its derivatives
1333             fac=(rrij*sigsq)**expon2
1334             e1=fac*fac*aa(itypi,itypj)
1335             e2=fac*bb(itypi,itypj)
1336             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1337             eps2der=evdwij*eps3rt
1338             eps3der=evdwij*eps2rt
1339             evdwij=evdwij*eps2rt*eps3rt
1340             evdw=evdw+evdwij
1341             if (lprn) then
1342             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1343             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1344 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1345 cd     &        restyp(itypi),i,restyp(itypj),j,
1346 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1347 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1348 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1349 cd     &        evdwij
1350             endif
1351 C Calculate gradient components.
1352             e1=e1*eps1*eps2rt**2*eps3rt**2
1353             fac=-expon*(e1+evdwij)
1354             sigder=fac/sigsq
1355             fac=rrij*fac
1356 C Calculate radial part of the gradient
1357             gg(1)=xj*fac
1358             gg(2)=yj*fac
1359             gg(3)=zj*fac
1360 C Calculate the angular part of the gradient and sum add the contributions
1361 C to the appropriate components of the Cartesian gradient.
1362             call sc_grad
1363           enddo      ! j
1364         enddo        ! iint
1365       enddo          ! i
1366 c     stop
1367       return
1368       end
1369 C-----------------------------------------------------------------------------
1370       subroutine egb(evdw)
1371 C
1372 C This subroutine calculates the interaction energy of nonbonded side chains
1373 C assuming the Gay-Berne potential of interaction.
1374 C
1375       implicit real*8 (a-h,o-z)
1376       include 'DIMENSIONS'
1377       include 'COMMON.GEO'
1378       include 'COMMON.VAR'
1379       include 'COMMON.LOCAL'
1380       include 'COMMON.CHAIN'
1381       include 'COMMON.DERIV'
1382       include 'COMMON.NAMES'
1383       include 'COMMON.INTERACT'
1384       include 'COMMON.IOUNITS'
1385       include 'COMMON.CALC'
1386       include 'COMMON.CONTROL'
1387       logical lprn
1388       evdw=0.0D0
1389 ccccc      energy_dec=.false.
1390 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1391       evdw=0.0D0
1392       lprn=.false.
1393 c     if (icall.eq.0) lprn=.false.
1394       ind=0
1395       do i=iatsc_s,iatsc_e
1396         itypi=itype(i)
1397         if (itypi.eq.21) cycle
1398         itypi1=itype(i+1)
1399         xi=c(1,nres+i)
1400         yi=c(2,nres+i)
1401         zi=c(3,nres+i)
1402         dxi=dc_norm(1,nres+i)
1403         dyi=dc_norm(2,nres+i)
1404         dzi=dc_norm(3,nres+i)
1405 c        dsci_inv=dsc_inv(itypi)
1406         dsci_inv=vbld_inv(i+nres)
1407 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1408 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1409 C
1410 C Calculate SC interaction energy.
1411 C
1412         do iint=1,nint_gr(i)
1413           do j=istart(i,iint),iend(i,iint)
1414             ind=ind+1
1415             itypj=itype(j)
1416             if (itypj.eq.21) cycle
1417 c            dscj_inv=dsc_inv(itypj)
1418             dscj_inv=vbld_inv(j+nres)
1419 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1420 c     &       1.0d0/vbld(j+nres)
1421 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1422             sig0ij=sigma(itypi,itypj)
1423             chi1=chi(itypi,itypj)
1424             chi2=chi(itypj,itypi)
1425             chi12=chi1*chi2
1426             chip1=chip(itypi)
1427             chip2=chip(itypj)
1428             chip12=chip1*chip2
1429             alf1=alp(itypi)
1430             alf2=alp(itypj)
1431             alf12=0.5D0*(alf1+alf2)
1432 C For diagnostics only!!!
1433 c           chi1=0.0D0
1434 c           chi2=0.0D0
1435 c           chi12=0.0D0
1436 c           chip1=0.0D0
1437 c           chip2=0.0D0
1438 c           chip12=0.0D0
1439 c           alf1=0.0D0
1440 c           alf2=0.0D0
1441 c           alf12=0.0D0
1442             xj=c(1,nres+j)-xi
1443             yj=c(2,nres+j)-yi
1444             zj=c(3,nres+j)-zi
1445             dxj=dc_norm(1,nres+j)
1446             dyj=dc_norm(2,nres+j)
1447             dzj=dc_norm(3,nres+j)
1448 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1449 c            write (iout,*) "j",j," dc_norm",
1450 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1451             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1452             rij=dsqrt(rrij)
1453 C Calculate angle-dependent terms of energy and contributions to their
1454 C derivatives.
1455             call sc_angular
1456             sigsq=1.0D0/sigsq
1457             sig=sig0ij*dsqrt(sigsq)
1458             rij_shift=1.0D0/rij-sig+sig0ij
1459 c for diagnostics; uncomment
1460 c            rij_shift=1.2*sig0ij
1461 C I hate to put IF's in the loops, but here don't have another choice!!!!
1462             if (rij_shift.le.0.0D0) then
1463               evdw=1.0D20
1464 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1465 cd     &        restyp(itypi),i,restyp(itypj),j,
1466 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1467               return
1468             endif
1469             sigder=-sig*sigsq
1470 c---------------------------------------------------------------
1471             rij_shift=1.0D0/rij_shift
1472             fac=rij_shift**expon
1473             e1=fac*fac*aa(itypi,itypj)
1474             e2=fac*bb(itypi,itypj)
1475             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1476             eps2der=evdwij*eps3rt
1477             eps3der=evdwij*eps2rt
1478 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1479 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1480             evdwij=evdwij*eps2rt*eps3rt
1481             evdw=evdw+evdwij
1482             if (lprn) then
1483             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1484             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1485             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1486      &        restyp(itypi),i,restyp(itypj),j,
1487      &        epsi,sigm,chi1,chi2,chip1,chip2,
1488      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1489      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1490      &        evdwij
1491             endif
1492
1493             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1494      &                        'evdw',i,j,evdwij
1495
1496 C Calculate gradient components.
1497             e1=e1*eps1*eps2rt**2*eps3rt**2
1498             fac=-expon*(e1+evdwij)*rij_shift
1499             sigder=fac*sigder
1500             fac=rij*fac
1501 c            fac=0.0d0
1502 C Calculate the radial part of the gradient
1503             gg(1)=xj*fac
1504             gg(2)=yj*fac
1505             gg(3)=zj*fac
1506 C Calculate angular part of the gradient.
1507             call sc_grad
1508           enddo      ! j
1509         enddo        ! iint
1510       enddo          ! i
1511 c      write (iout,*) "Number of loop steps in EGB:",ind
1512 cccc      energy_dec=.false.
1513       return
1514       end
1515 C-----------------------------------------------------------------------------
1516       subroutine egbv(evdw)
1517 C
1518 C This subroutine calculates the interaction energy of nonbonded side chains
1519 C assuming the Gay-Berne-Vorobjev potential of interaction.
1520 C
1521       implicit real*8 (a-h,o-z)
1522       include 'DIMENSIONS'
1523       include 'COMMON.GEO'
1524       include 'COMMON.VAR'
1525       include 'COMMON.LOCAL'
1526       include 'COMMON.CHAIN'
1527       include 'COMMON.DERIV'
1528       include 'COMMON.NAMES'
1529       include 'COMMON.INTERACT'
1530       include 'COMMON.IOUNITS'
1531       include 'COMMON.CALC'
1532       common /srutu/ icall
1533       logical lprn
1534       evdw=0.0D0
1535 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1536       evdw=0.0D0
1537       lprn=.false.
1538 c     if (icall.eq.0) lprn=.true.
1539       ind=0
1540       do i=iatsc_s,iatsc_e
1541         itypi=itype(i)
1542         if (itypi.eq.21) cycle
1543         itypi1=itype(i+1)
1544         xi=c(1,nres+i)
1545         yi=c(2,nres+i)
1546         zi=c(3,nres+i)
1547         dxi=dc_norm(1,nres+i)
1548         dyi=dc_norm(2,nres+i)
1549         dzi=dc_norm(3,nres+i)
1550 c        dsci_inv=dsc_inv(itypi)
1551         dsci_inv=vbld_inv(i+nres)
1552 C
1553 C Calculate SC interaction energy.
1554 C
1555         do iint=1,nint_gr(i)
1556           do j=istart(i,iint),iend(i,iint)
1557             ind=ind+1
1558             itypj=itype(j)
1559             if (itypj.eq.21) cycle
1560 c            dscj_inv=dsc_inv(itypj)
1561             dscj_inv=vbld_inv(j+nres)
1562             sig0ij=sigma(itypi,itypj)
1563             r0ij=r0(itypi,itypj)
1564             chi1=chi(itypi,itypj)
1565             chi2=chi(itypj,itypi)
1566             chi12=chi1*chi2
1567             chip1=chip(itypi)
1568             chip2=chip(itypj)
1569             chip12=chip1*chip2
1570             alf1=alp(itypi)
1571             alf2=alp(itypj)
1572             alf12=0.5D0*(alf1+alf2)
1573 C For diagnostics only!!!
1574 c           chi1=0.0D0
1575 c           chi2=0.0D0
1576 c           chi12=0.0D0
1577 c           chip1=0.0D0
1578 c           chip2=0.0D0
1579 c           chip12=0.0D0
1580 c           alf1=0.0D0
1581 c           alf2=0.0D0
1582 c           alf12=0.0D0
1583             xj=c(1,nres+j)-xi
1584             yj=c(2,nres+j)-yi
1585             zj=c(3,nres+j)-zi
1586             dxj=dc_norm(1,nres+j)
1587             dyj=dc_norm(2,nres+j)
1588             dzj=dc_norm(3,nres+j)
1589             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1590             rij=dsqrt(rrij)
1591 C Calculate angle-dependent terms of energy and contributions to their
1592 C derivatives.
1593             call sc_angular
1594             sigsq=1.0D0/sigsq
1595             sig=sig0ij*dsqrt(sigsq)
1596             rij_shift=1.0D0/rij-sig+r0ij
1597 C I hate to put IF's in the loops, but here don't have another choice!!!!
1598             if (rij_shift.le.0.0D0) then
1599               evdw=1.0D20
1600               return
1601             endif
1602             sigder=-sig*sigsq
1603 c---------------------------------------------------------------
1604             rij_shift=1.0D0/rij_shift
1605             fac=rij_shift**expon
1606             e1=fac*fac*aa(itypi,itypj)
1607             e2=fac*bb(itypi,itypj)
1608             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1609             eps2der=evdwij*eps3rt
1610             eps3der=evdwij*eps2rt
1611             fac_augm=rrij**expon
1612             e_augm=augm(itypi,itypj)*fac_augm
1613             evdwij=evdwij*eps2rt*eps3rt
1614             evdw=evdw+evdwij+e_augm
1615             if (lprn) then
1616             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1617             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1618             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1619      &        restyp(itypi),i,restyp(itypj),j,
1620      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1621      &        chi1,chi2,chip1,chip2,
1622      &        eps1,eps2rt**2,eps3rt**2,
1623      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1624      &        evdwij+e_augm
1625             endif
1626 C Calculate gradient components.
1627             e1=e1*eps1*eps2rt**2*eps3rt**2
1628             fac=-expon*(e1+evdwij)*rij_shift
1629             sigder=fac*sigder
1630             fac=rij*fac-2*expon*rrij*e_augm
1631 C Calculate the radial part of the gradient
1632             gg(1)=xj*fac
1633             gg(2)=yj*fac
1634             gg(3)=zj*fac
1635 C Calculate angular part of the gradient.
1636             call sc_grad
1637           enddo      ! j
1638         enddo        ! iint
1639       enddo          ! i
1640       end
1641 C-----------------------------------------------------------------------------
1642       subroutine sc_angular
1643 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1644 C om12. Called by ebp, egb, and egbv.
1645       implicit none
1646       include 'COMMON.CALC'
1647       include 'COMMON.IOUNITS'
1648       erij(1)=xj*rij
1649       erij(2)=yj*rij
1650       erij(3)=zj*rij
1651       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1652       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1653       om12=dxi*dxj+dyi*dyj+dzi*dzj
1654       chiom12=chi12*om12
1655 C Calculate eps1(om12) and its derivative in om12
1656       faceps1=1.0D0-om12*chiom12
1657       faceps1_inv=1.0D0/faceps1
1658       eps1=dsqrt(faceps1_inv)
1659 C Following variable is eps1*deps1/dom12
1660       eps1_om12=faceps1_inv*chiom12
1661 c diagnostics only
1662 c      faceps1_inv=om12
1663 c      eps1=om12
1664 c      eps1_om12=1.0d0
1665 c      write (iout,*) "om12",om12," eps1",eps1
1666 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1667 C and om12.
1668       om1om2=om1*om2
1669       chiom1=chi1*om1
1670       chiom2=chi2*om2
1671       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1672       sigsq=1.0D0-facsig*faceps1_inv
1673       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1674       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1675       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1676 c diagnostics only
1677 c      sigsq=1.0d0
1678 c      sigsq_om1=0.0d0
1679 c      sigsq_om2=0.0d0
1680 c      sigsq_om12=0.0d0
1681 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1682 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1683 c     &    " eps1",eps1
1684 C Calculate eps2 and its derivatives in om1, om2, and om12.
1685       chipom1=chip1*om1
1686       chipom2=chip2*om2
1687       chipom12=chip12*om12
1688       facp=1.0D0-om12*chipom12
1689       facp_inv=1.0D0/facp
1690       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1691 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1692 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1693 C Following variable is the square root of eps2
1694       eps2rt=1.0D0-facp1*facp_inv
1695 C Following three variables are the derivatives of the square root of eps
1696 C in om1, om2, and om12.
1697       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1698       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1699       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1700 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1701       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1702 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1703 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1704 c     &  " eps2rt_om12",eps2rt_om12
1705 C Calculate whole angle-dependent part of epsilon and contributions
1706 C to its derivatives
1707       return
1708       end
1709 C----------------------------------------------------------------------------
1710       subroutine sc_grad
1711       implicit real*8 (a-h,o-z)
1712       include 'DIMENSIONS'
1713       include 'COMMON.CHAIN'
1714       include 'COMMON.DERIV'
1715       include 'COMMON.CALC'
1716       include 'COMMON.IOUNITS'
1717       double precision dcosom1(3),dcosom2(3)
1718       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1719       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1720       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1721      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1722 c diagnostics only
1723 c      eom1=0.0d0
1724 c      eom2=0.0d0
1725 c      eom12=evdwij*eps1_om12
1726 c end diagnostics
1727 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1728 c     &  " sigder",sigder
1729 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1730 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1731       do k=1,3
1732         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1733         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1734       enddo
1735       do k=1,3
1736         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1737       enddo
1738 c      write (iout,*) "gg",(gg(k),k=1,3)
1739       do k=1,3
1740         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1741      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1742      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1743         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1744      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1745      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1746 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1747 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1748 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1749 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1750       enddo
1751 C
1752 C Calculate the components of the gradient in DC and X
1753 C
1754 cgrad      do k=i,j-1
1755 cgrad        do l=1,3
1756 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1757 cgrad        enddo
1758 cgrad      enddo
1759       do l=1,3
1760         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1761         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1762       enddo
1763       return
1764       end
1765 C-----------------------------------------------------------------------
1766       subroutine e_softsphere(evdw)
1767 C
1768 C This subroutine calculates the interaction energy of nonbonded side chains
1769 C assuming the LJ potential of interaction.
1770 C
1771       implicit real*8 (a-h,o-z)
1772       include 'DIMENSIONS'
1773       parameter (accur=1.0d-10)
1774       include 'COMMON.GEO'
1775       include 'COMMON.VAR'
1776       include 'COMMON.LOCAL'
1777       include 'COMMON.CHAIN'
1778       include 'COMMON.DERIV'
1779       include 'COMMON.INTERACT'
1780       include 'COMMON.TORSION'
1781       include 'COMMON.SBRIDGE'
1782       include 'COMMON.NAMES'
1783       include 'COMMON.IOUNITS'
1784       include 'COMMON.CONTACTS'
1785       dimension gg(3)
1786 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1787       evdw=0.0D0
1788       do i=iatsc_s,iatsc_e
1789         itypi=itype(i)
1790         if (itypi.eq.21) cycle
1791         itypi1=itype(i+1)
1792         xi=c(1,nres+i)
1793         yi=c(2,nres+i)
1794         zi=c(3,nres+i)
1795 C
1796 C Calculate SC interaction energy.
1797 C
1798         do iint=1,nint_gr(i)
1799 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1800 cd   &                  'iend=',iend(i,iint)
1801           do j=istart(i,iint),iend(i,iint)
1802             itypj=itype(j)
1803             if (itypj.eq.21) cycle
1804             xj=c(1,nres+j)-xi
1805             yj=c(2,nres+j)-yi
1806             zj=c(3,nres+j)-zi
1807             rij=xj*xj+yj*yj+zj*zj
1808 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1809             r0ij=r0(itypi,itypj)
1810             r0ijsq=r0ij*r0ij
1811 c            print *,i,j,r0ij,dsqrt(rij)
1812             if (rij.lt.r0ijsq) then
1813               evdwij=0.25d0*(rij-r0ijsq)**2
1814               fac=rij-r0ijsq
1815             else
1816               evdwij=0.0d0
1817               fac=0.0d0
1818             endif
1819             evdw=evdw+evdwij
1820 C
1821 C Calculate the components of the gradient in DC and X
1822 C
1823             gg(1)=xj*fac
1824             gg(2)=yj*fac
1825             gg(3)=zj*fac
1826             do k=1,3
1827               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1828               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1829               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1830               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1831             enddo
1832 cgrad            do k=i,j-1
1833 cgrad              do l=1,3
1834 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1835 cgrad              enddo
1836 cgrad            enddo
1837           enddo ! j
1838         enddo ! iint
1839       enddo ! i
1840       return
1841       end
1842 C--------------------------------------------------------------------------
1843       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1844      &              eello_turn4)
1845 C
1846 C Soft-sphere potential of p-p interaction
1847 C
1848       implicit real*8 (a-h,o-z)
1849       include 'DIMENSIONS'
1850       include 'COMMON.CONTROL'
1851       include 'COMMON.IOUNITS'
1852       include 'COMMON.GEO'
1853       include 'COMMON.VAR'
1854       include 'COMMON.LOCAL'
1855       include 'COMMON.CHAIN'
1856       include 'COMMON.DERIV'
1857       include 'COMMON.INTERACT'
1858       include 'COMMON.CONTACTS'
1859       include 'COMMON.TORSION'
1860       include 'COMMON.VECTORS'
1861       include 'COMMON.FFIELD'
1862       dimension ggg(3)
1863 cd      write(iout,*) 'In EELEC_soft_sphere'
1864       ees=0.0D0
1865       evdw1=0.0D0
1866       eel_loc=0.0d0
1867       eello_turn3=0.0d0
1868       eello_turn4=0.0d0
1869       ind=0
1870       do i=iatel_s,iatel_e
1871         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
1872         dxi=dc(1,i)
1873         dyi=dc(2,i)
1874         dzi=dc(3,i)
1875         xmedi=c(1,i)+0.5d0*dxi
1876         ymedi=c(2,i)+0.5d0*dyi
1877         zmedi=c(3,i)+0.5d0*dzi
1878         num_conti=0
1879 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1880         do j=ielstart(i),ielend(i)
1881           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
1882           ind=ind+1
1883           iteli=itel(i)
1884           itelj=itel(j)
1885           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1886           r0ij=rpp(iteli,itelj)
1887           r0ijsq=r0ij*r0ij
1888           dxj=dc(1,j)
1889           dyj=dc(2,j)
1890           dzj=dc(3,j)
1891           xj=c(1,j)+0.5D0*dxj-xmedi
1892           yj=c(2,j)+0.5D0*dyj-ymedi
1893           zj=c(3,j)+0.5D0*dzj-zmedi
1894           rij=xj*xj+yj*yj+zj*zj
1895           if (rij.lt.r0ijsq) then
1896             evdw1ij=0.25d0*(rij-r0ijsq)**2
1897             fac=rij-r0ijsq
1898           else
1899             evdw1ij=0.0d0
1900             fac=0.0d0
1901           endif
1902           evdw1=evdw1+evdw1ij
1903 C
1904 C Calculate contributions to the Cartesian gradient.
1905 C
1906           ggg(1)=fac*xj
1907           ggg(2)=fac*yj
1908           ggg(3)=fac*zj
1909           do k=1,3
1910             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1911             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1912           enddo
1913 *
1914 * Loop over residues i+1 thru j-1.
1915 *
1916 cgrad          do k=i+1,j-1
1917 cgrad            do l=1,3
1918 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1919 cgrad            enddo
1920 cgrad          enddo
1921         enddo ! j
1922       enddo   ! i
1923 cgrad      do i=nnt,nct-1
1924 cgrad        do k=1,3
1925 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1926 cgrad        enddo
1927 cgrad        do j=i+1,nct-1
1928 cgrad          do k=1,3
1929 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1930 cgrad          enddo
1931 cgrad        enddo
1932 cgrad      enddo
1933       return
1934       end
1935 c------------------------------------------------------------------------------
1936       subroutine vec_and_deriv
1937       implicit real*8 (a-h,o-z)
1938       include 'DIMENSIONS'
1939 #ifdef MPI
1940       include 'mpif.h'
1941 #endif
1942       include 'COMMON.IOUNITS'
1943       include 'COMMON.GEO'
1944       include 'COMMON.VAR'
1945       include 'COMMON.LOCAL'
1946       include 'COMMON.CHAIN'
1947       include 'COMMON.VECTORS'
1948       include 'COMMON.SETUP'
1949       include 'COMMON.TIME1'
1950       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1951 C Compute the local reference systems. For reference system (i), the
1952 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1953 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1954 #ifdef PARVEC
1955       do i=ivec_start,ivec_end
1956 #else
1957       do i=1,nres-1
1958 #endif
1959           if (i.eq.nres-1) then
1960 C Case of the last full residue
1961 C Compute the Z-axis
1962             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1963             costh=dcos(pi-theta(nres))
1964             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1965             do k=1,3
1966               uz(k,i)=fac*uz(k,i)
1967             enddo
1968 C Compute the derivatives of uz
1969             uzder(1,1,1)= 0.0d0
1970             uzder(2,1,1)=-dc_norm(3,i-1)
1971             uzder(3,1,1)= dc_norm(2,i-1)
1972             uzder(1,2,1)= dc_norm(3,i-1)
1973             uzder(2,2,1)= 0.0d0
1974             uzder(3,2,1)=-dc_norm(1,i-1)
1975             uzder(1,3,1)=-dc_norm(2,i-1)
1976             uzder(2,3,1)= dc_norm(1,i-1)
1977             uzder(3,3,1)= 0.0d0
1978             uzder(1,1,2)= 0.0d0
1979             uzder(2,1,2)= dc_norm(3,i)
1980             uzder(3,1,2)=-dc_norm(2,i)
1981             uzder(1,2,2)=-dc_norm(3,i)
1982             uzder(2,2,2)= 0.0d0
1983             uzder(3,2,2)= dc_norm(1,i)
1984             uzder(1,3,2)= dc_norm(2,i)
1985             uzder(2,3,2)=-dc_norm(1,i)
1986             uzder(3,3,2)= 0.0d0
1987 C Compute the Y-axis
1988             facy=fac
1989             do k=1,3
1990               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1991             enddo
1992 C Compute the derivatives of uy
1993             do j=1,3
1994               do k=1,3
1995                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1996      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1997                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1998               enddo
1999               uyder(j,j,1)=uyder(j,j,1)-costh
2000               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2001             enddo
2002             do j=1,2
2003               do k=1,3
2004                 do l=1,3
2005                   uygrad(l,k,j,i)=uyder(l,k,j)
2006                   uzgrad(l,k,j,i)=uzder(l,k,j)
2007                 enddo
2008               enddo
2009             enddo
2010             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2011             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2012             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2013             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2014           else
2015 C Other residues
2016 C Compute the Z-axis
2017             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2018             costh=dcos(pi-theta(i+2))
2019             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2020             do k=1,3
2021               uz(k,i)=fac*uz(k,i)
2022             enddo
2023 C Compute the derivatives of uz
2024             uzder(1,1,1)= 0.0d0
2025             uzder(2,1,1)=-dc_norm(3,i+1)
2026             uzder(3,1,1)= dc_norm(2,i+1)
2027             uzder(1,2,1)= dc_norm(3,i+1)
2028             uzder(2,2,1)= 0.0d0
2029             uzder(3,2,1)=-dc_norm(1,i+1)
2030             uzder(1,3,1)=-dc_norm(2,i+1)
2031             uzder(2,3,1)= dc_norm(1,i+1)
2032             uzder(3,3,1)= 0.0d0
2033             uzder(1,1,2)= 0.0d0
2034             uzder(2,1,2)= dc_norm(3,i)
2035             uzder(3,1,2)=-dc_norm(2,i)
2036             uzder(1,2,2)=-dc_norm(3,i)
2037             uzder(2,2,2)= 0.0d0
2038             uzder(3,2,2)= dc_norm(1,i)
2039             uzder(1,3,2)= dc_norm(2,i)
2040             uzder(2,3,2)=-dc_norm(1,i)
2041             uzder(3,3,2)= 0.0d0
2042 C Compute the Y-axis
2043             facy=fac
2044             do k=1,3
2045               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2046             enddo
2047 C Compute the derivatives of uy
2048             do j=1,3
2049               do k=1,3
2050                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2051      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2052                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2053               enddo
2054               uyder(j,j,1)=uyder(j,j,1)-costh
2055               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2056             enddo
2057             do j=1,2
2058               do k=1,3
2059                 do l=1,3
2060                   uygrad(l,k,j,i)=uyder(l,k,j)
2061                   uzgrad(l,k,j,i)=uzder(l,k,j)
2062                 enddo
2063               enddo
2064             enddo
2065             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2066             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2067             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2068             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2069           endif
2070       enddo
2071       do i=1,nres-1
2072         vbld_inv_temp(1)=vbld_inv(i+1)
2073         if (i.lt.nres-1) then
2074           vbld_inv_temp(2)=vbld_inv(i+2)
2075           else
2076           vbld_inv_temp(2)=vbld_inv(i)
2077           endif
2078         do j=1,2
2079           do k=1,3
2080             do l=1,3
2081               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2082               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2083             enddo
2084           enddo
2085         enddo
2086       enddo
2087 #if defined(PARVEC) && defined(MPI)
2088       if (nfgtasks1.gt.1) then
2089         time00=MPI_Wtime()
2090 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2091 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2092 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2093         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2094      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2095      &   FG_COMM1,IERR)
2096         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2097      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2098      &   FG_COMM1,IERR)
2099         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2100      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2101      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2102         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2103      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2104      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2105         time_gather=time_gather+MPI_Wtime()-time00
2106       endif
2107 c      if (fg_rank.eq.0) then
2108 c        write (iout,*) "Arrays UY and UZ"
2109 c        do i=1,nres-1
2110 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2111 c     &     (uz(k,i),k=1,3)
2112 c        enddo
2113 c      endif
2114 #endif
2115       return
2116       end
2117 C-----------------------------------------------------------------------------
2118       subroutine check_vecgrad
2119       implicit real*8 (a-h,o-z)
2120       include 'DIMENSIONS'
2121       include 'COMMON.IOUNITS'
2122       include 'COMMON.GEO'
2123       include 'COMMON.VAR'
2124       include 'COMMON.LOCAL'
2125       include 'COMMON.CHAIN'
2126       include 'COMMON.VECTORS'
2127       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2128       dimension uyt(3,maxres),uzt(3,maxres)
2129       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2130       double precision delta /1.0d-7/
2131       call vec_and_deriv
2132 cd      do i=1,nres
2133 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2134 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2135 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2136 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2137 cd     &     (dc_norm(if90,i),if90=1,3)
2138 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2139 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2140 cd          write(iout,'(a)')
2141 cd      enddo
2142       do i=1,nres
2143         do j=1,2
2144           do k=1,3
2145             do l=1,3
2146               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2147               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2148             enddo
2149           enddo
2150         enddo
2151       enddo
2152       call vec_and_deriv
2153       do i=1,nres
2154         do j=1,3
2155           uyt(j,i)=uy(j,i)
2156           uzt(j,i)=uz(j,i)
2157         enddo
2158       enddo
2159       do i=1,nres
2160 cd        write (iout,*) 'i=',i
2161         do k=1,3
2162           erij(k)=dc_norm(k,i)
2163         enddo
2164         do j=1,3
2165           do k=1,3
2166             dc_norm(k,i)=erij(k)
2167           enddo
2168           dc_norm(j,i)=dc_norm(j,i)+delta
2169 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2170 c          do k=1,3
2171 c            dc_norm(k,i)=dc_norm(k,i)/fac
2172 c          enddo
2173 c          write (iout,*) (dc_norm(k,i),k=1,3)
2174 c          write (iout,*) (erij(k),k=1,3)
2175           call vec_and_deriv
2176           do k=1,3
2177             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2178             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2179             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2180             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2181           enddo
2182 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2183 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2184 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2185         enddo
2186         do k=1,3
2187           dc_norm(k,i)=erij(k)
2188         enddo
2189 cd        do k=1,3
2190 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2191 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2192 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2193 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2194 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2195 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2196 cd          write (iout,'(a)')
2197 cd        enddo
2198       enddo
2199       return
2200       end
2201 C--------------------------------------------------------------------------
2202       subroutine set_matrices
2203       implicit real*8 (a-h,o-z)
2204       include 'DIMENSIONS'
2205 #ifdef MPI
2206       include "mpif.h"
2207       include "COMMON.SETUP"
2208       integer IERR
2209       integer status(MPI_STATUS_SIZE)
2210 #endif
2211       include 'COMMON.IOUNITS'
2212       include 'COMMON.GEO'
2213       include 'COMMON.VAR'
2214       include 'COMMON.LOCAL'
2215       include 'COMMON.CHAIN'
2216       include 'COMMON.DERIV'
2217       include 'COMMON.INTERACT'
2218       include 'COMMON.CONTACTS'
2219       include 'COMMON.TORSION'
2220       include 'COMMON.VECTORS'
2221       include 'COMMON.FFIELD'
2222       double precision auxvec(2),auxmat(2,2)
2223 C
2224 C Compute the virtual-bond-torsional-angle dependent quantities needed
2225 C to calculate the el-loc multibody terms of various order.
2226 C
2227 #ifdef PARMAT
2228       do i=ivec_start+2,ivec_end+2
2229 #else
2230       do i=3,nres+1
2231 #endif
2232         if (i .lt. nres+1) then
2233           sin1=dsin(phi(i))
2234           cos1=dcos(phi(i))
2235           sintab(i-2)=sin1
2236           costab(i-2)=cos1
2237           obrot(1,i-2)=cos1
2238           obrot(2,i-2)=sin1
2239           sin2=dsin(2*phi(i))
2240           cos2=dcos(2*phi(i))
2241           sintab2(i-2)=sin2
2242           costab2(i-2)=cos2
2243           obrot2(1,i-2)=cos2
2244           obrot2(2,i-2)=sin2
2245           Ug(1,1,i-2)=-cos1
2246           Ug(1,2,i-2)=-sin1
2247           Ug(2,1,i-2)=-sin1
2248           Ug(2,2,i-2)= cos1
2249           Ug2(1,1,i-2)=-cos2
2250           Ug2(1,2,i-2)=-sin2
2251           Ug2(2,1,i-2)=-sin2
2252           Ug2(2,2,i-2)= cos2
2253         else
2254           costab(i-2)=1.0d0
2255           sintab(i-2)=0.0d0
2256           obrot(1,i-2)=1.0d0
2257           obrot(2,i-2)=0.0d0
2258           obrot2(1,i-2)=0.0d0
2259           obrot2(2,i-2)=0.0d0
2260           Ug(1,1,i-2)=1.0d0
2261           Ug(1,2,i-2)=0.0d0
2262           Ug(2,1,i-2)=0.0d0
2263           Ug(2,2,i-2)=1.0d0
2264           Ug2(1,1,i-2)=0.0d0
2265           Ug2(1,2,i-2)=0.0d0
2266           Ug2(2,1,i-2)=0.0d0
2267           Ug2(2,2,i-2)=0.0d0
2268         endif
2269         if (i .gt. 3 .and. i .lt. nres+1) then
2270           obrot_der(1,i-2)=-sin1
2271           obrot_der(2,i-2)= cos1
2272           Ugder(1,1,i-2)= sin1
2273           Ugder(1,2,i-2)=-cos1
2274           Ugder(2,1,i-2)=-cos1
2275           Ugder(2,2,i-2)=-sin1
2276           dwacos2=cos2+cos2
2277           dwasin2=sin2+sin2
2278           obrot2_der(1,i-2)=-dwasin2
2279           obrot2_der(2,i-2)= dwacos2
2280           Ug2der(1,1,i-2)= dwasin2
2281           Ug2der(1,2,i-2)=-dwacos2
2282           Ug2der(2,1,i-2)=-dwacos2
2283           Ug2der(2,2,i-2)=-dwasin2
2284         else
2285           obrot_der(1,i-2)=0.0d0
2286           obrot_der(2,i-2)=0.0d0
2287           Ugder(1,1,i-2)=0.0d0
2288           Ugder(1,2,i-2)=0.0d0
2289           Ugder(2,1,i-2)=0.0d0
2290           Ugder(2,2,i-2)=0.0d0
2291           obrot2_der(1,i-2)=0.0d0
2292           obrot2_der(2,i-2)=0.0d0
2293           Ug2der(1,1,i-2)=0.0d0
2294           Ug2der(1,2,i-2)=0.0d0
2295           Ug2der(2,1,i-2)=0.0d0
2296           Ug2der(2,2,i-2)=0.0d0
2297         endif
2298 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2299         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2300           iti = itortyp(itype(i-2))
2301         else
2302           iti=ntortyp+1
2303         endif
2304 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2305         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2306           iti1 = itortyp(itype(i-1))
2307         else
2308           iti1=ntortyp+1
2309         endif
2310 cd        write (iout,*) '*******i',i,' iti1',iti
2311 cd        write (iout,*) 'b1',b1(:,iti)
2312 cd        write (iout,*) 'b2',b2(:,iti)
2313 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2314 c        if (i .gt. iatel_s+2) then
2315         if (i .gt. nnt+2) then
2316           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2317           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2318           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2319      &    then
2320           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2321           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2322           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2323           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2324           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2325           endif
2326         else
2327           do k=1,2
2328             Ub2(k,i-2)=0.0d0
2329             Ctobr(k,i-2)=0.0d0
2330             Dtobr2(k,i-2)=0.0d0
2331             do l=1,2
2332               EUg(l,k,i-2)=0.0d0
2333               CUg(l,k,i-2)=0.0d0
2334               DUg(l,k,i-2)=0.0d0
2335               DtUg2(l,k,i-2)=0.0d0
2336             enddo
2337           enddo
2338         endif
2339         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2340         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2341         do k=1,2
2342           muder(k,i-2)=Ub2der(k,i-2)
2343         enddo
2344 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2345         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2346           iti1 = itortyp(itype(i-1))
2347         else
2348           iti1=ntortyp+1
2349         endif
2350         do k=1,2
2351           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2352         enddo
2353 cd        write (iout,*) 'mu ',mu(:,i-2)
2354 cd        write (iout,*) 'mu1',mu1(:,i-2)
2355 cd        write (iout,*) 'mu2',mu2(:,i-2)
2356         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2357      &  then
2358         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2359         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2360         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2361         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2362         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2363 C Vectors and matrices dependent on a single virtual-bond dihedral.
2364         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2365         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2366         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2367         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2368         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2369         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2370         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2371         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2372         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2373         endif
2374       enddo
2375 C Matrices dependent on two consecutive virtual-bond dihedrals.
2376 C The order of matrices is from left to right.
2377       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2378      &then
2379 c      do i=max0(ivec_start,2),ivec_end
2380       do i=2,nres-1
2381         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2382         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2383         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2384         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2385         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2386         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2387         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2388         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2389       enddo
2390       endif
2391 #if defined(MPI) && defined(PARMAT)
2392 #ifdef DEBUG
2393 c      if (fg_rank.eq.0) then
2394         write (iout,*) "Arrays UG and UGDER before GATHER"
2395         do i=1,nres-1
2396           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2397      &     ((ug(l,k,i),l=1,2),k=1,2),
2398      &     ((ugder(l,k,i),l=1,2),k=1,2)
2399         enddo
2400         write (iout,*) "Arrays UG2 and UG2DER"
2401         do i=1,nres-1
2402           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2403      &     ((ug2(l,k,i),l=1,2),k=1,2),
2404      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2405         enddo
2406         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2407         do i=1,nres-1
2408           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2409      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2410      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2411         enddo
2412         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2413         do i=1,nres-1
2414           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2415      &     costab(i),sintab(i),costab2(i),sintab2(i)
2416         enddo
2417         write (iout,*) "Array MUDER"
2418         do i=1,nres-1
2419           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2420         enddo
2421 c      endif
2422 #endif
2423       if (nfgtasks.gt.1) then
2424         time00=MPI_Wtime()
2425 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2426 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2427 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2428 #ifdef MATGATHER
2429         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2430      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2431      &   FG_COMM1,IERR)
2432         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2433      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2434      &   FG_COMM1,IERR)
2435         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2436      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2437      &   FG_COMM1,IERR)
2438         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2439      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2440      &   FG_COMM1,IERR)
2441         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2442      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2443      &   FG_COMM1,IERR)
2444         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2445      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2446      &   FG_COMM1,IERR)
2447         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2448      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2449      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2450         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2451      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2452      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2453         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2454      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2455      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2456         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2457      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2458      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2459         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2460      &  then
2461         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2462      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2463      &   FG_COMM1,IERR)
2464         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2465      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2466      &   FG_COMM1,IERR)
2467         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2468      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2469      &   FG_COMM1,IERR)
2470        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2471      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2472      &   FG_COMM1,IERR)
2473         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2474      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2475      &   FG_COMM1,IERR)
2476         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2477      &   ivec_count(fg_rank1),
2478      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2479      &   FG_COMM1,IERR)
2480         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2481      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2482      &   FG_COMM1,IERR)
2483         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2484      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2485      &   FG_COMM1,IERR)
2486         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2487      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2488      &   FG_COMM1,IERR)
2489         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2490      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2491      &   FG_COMM1,IERR)
2492         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2493      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2494      &   FG_COMM1,IERR)
2495         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2496      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2497      &   FG_COMM1,IERR)
2498         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2499      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2500      &   FG_COMM1,IERR)
2501         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2502      &   ivec_count(fg_rank1),
2503      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2504      &   FG_COMM1,IERR)
2505         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2506      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2507      &   FG_COMM1,IERR)
2508        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2509      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2510      &   FG_COMM1,IERR)
2511         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2512      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2513      &   FG_COMM1,IERR)
2514        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2515      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2516      &   FG_COMM1,IERR)
2517         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2518      &   ivec_count(fg_rank1),
2519      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2520      &   FG_COMM1,IERR)
2521         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2522      &   ivec_count(fg_rank1),
2523      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2524      &   FG_COMM1,IERR)
2525         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2526      &   ivec_count(fg_rank1),
2527      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2528      &   MPI_MAT2,FG_COMM1,IERR)
2529         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2530      &   ivec_count(fg_rank1),
2531      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2532      &   MPI_MAT2,FG_COMM1,IERR)
2533         endif
2534 #else
2535 c Passes matrix info through the ring
2536       isend=fg_rank1
2537       irecv=fg_rank1-1
2538       if (irecv.lt.0) irecv=nfgtasks1-1
2539       iprev=irecv
2540       inext=fg_rank1+1
2541       if (inext.ge.nfgtasks1) inext=0
2542       do i=1,nfgtasks1-1
2543 c        write (iout,*) "isend",isend," irecv",irecv
2544 c        call flush(iout)
2545         lensend=lentyp(isend)
2546         lenrecv=lentyp(irecv)
2547 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2548 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2549 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2550 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2551 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2552 c        write (iout,*) "Gather ROTAT1"
2553 c        call flush(iout)
2554 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2555 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2556 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2557 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2558 c        write (iout,*) "Gather ROTAT2"
2559 c        call flush(iout)
2560         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2561      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2562      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2563      &   iprev,4400+irecv,FG_COMM,status,IERR)
2564 c        write (iout,*) "Gather ROTAT_OLD"
2565 c        call flush(iout)
2566         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2567      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2568      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2569      &   iprev,5500+irecv,FG_COMM,status,IERR)
2570 c        write (iout,*) "Gather PRECOMP11"
2571 c        call flush(iout)
2572         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2573      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2574      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2575      &   iprev,6600+irecv,FG_COMM,status,IERR)
2576 c        write (iout,*) "Gather PRECOMP12"
2577 c        call flush(iout)
2578         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2579      &  then
2580         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2581      &   MPI_ROTAT2(lensend),inext,7700+isend,
2582      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2583      &   iprev,7700+irecv,FG_COMM,status,IERR)
2584 c        write (iout,*) "Gather PRECOMP21"
2585 c        call flush(iout)
2586         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2587      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2588      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2589      &   iprev,8800+irecv,FG_COMM,status,IERR)
2590 c        write (iout,*) "Gather PRECOMP22"
2591 c        call flush(iout)
2592         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2593      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2594      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2595      &   MPI_PRECOMP23(lenrecv),
2596      &   iprev,9900+irecv,FG_COMM,status,IERR)
2597 c        write (iout,*) "Gather PRECOMP23"
2598 c        call flush(iout)
2599         endif
2600         isend=irecv
2601         irecv=irecv-1
2602         if (irecv.lt.0) irecv=nfgtasks1-1
2603       enddo
2604 #endif
2605         time_gather=time_gather+MPI_Wtime()-time00
2606       endif
2607 #ifdef DEBUG
2608 c      if (fg_rank.eq.0) then
2609         write (iout,*) "Arrays UG and UGDER"
2610         do i=1,nres-1
2611           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2612      &     ((ug(l,k,i),l=1,2),k=1,2),
2613      &     ((ugder(l,k,i),l=1,2),k=1,2)
2614         enddo
2615         write (iout,*) "Arrays UG2 and UG2DER"
2616         do i=1,nres-1
2617           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2618      &     ((ug2(l,k,i),l=1,2),k=1,2),
2619      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2620         enddo
2621         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2622         do i=1,nres-1
2623           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2624      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2625      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2626         enddo
2627         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2628         do i=1,nres-1
2629           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2630      &     costab(i),sintab(i),costab2(i),sintab2(i)
2631         enddo
2632         write (iout,*) "Array MUDER"
2633         do i=1,nres-1
2634           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2635         enddo
2636 c      endif
2637 #endif
2638 #endif
2639 cd      do i=1,nres
2640 cd        iti = itortyp(itype(i))
2641 cd        write (iout,*) i
2642 cd        do j=1,2
2643 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2644 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2645 cd        enddo
2646 cd      enddo
2647       return
2648       end
2649 C--------------------------------------------------------------------------
2650       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2651 C
2652 C This subroutine calculates the average interaction energy and its gradient
2653 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2654 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2655 C The potential depends both on the distance of peptide-group centers and on
2656 C the orientation of the CA-CA virtual bonds.
2657 C
2658       implicit real*8 (a-h,o-z)
2659 #ifdef MPI
2660       include 'mpif.h'
2661 #endif
2662       include 'DIMENSIONS'
2663       include 'COMMON.CONTROL'
2664       include 'COMMON.SETUP'
2665       include 'COMMON.IOUNITS'
2666       include 'COMMON.GEO'
2667       include 'COMMON.VAR'
2668       include 'COMMON.LOCAL'
2669       include 'COMMON.CHAIN'
2670       include 'COMMON.DERIV'
2671       include 'COMMON.INTERACT'
2672       include 'COMMON.CONTACTS'
2673       include 'COMMON.TORSION'
2674       include 'COMMON.VECTORS'
2675       include 'COMMON.FFIELD'
2676       include 'COMMON.TIME1'
2677       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2678      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2679       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2680      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2681       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2682      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2683      &    num_conti,j1,j2
2684 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2685 #ifdef MOMENT
2686       double precision scal_el /1.0d0/
2687 #else
2688       double precision scal_el /0.5d0/
2689 #endif
2690 C 12/13/98
2691 C 13-go grudnia roku pamietnego...
2692       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2693      &                   0.0d0,1.0d0,0.0d0,
2694      &                   0.0d0,0.0d0,1.0d0/
2695 cd      write(iout,*) 'In EELEC'
2696 cd      do i=1,nloctyp
2697 cd        write(iout,*) 'Type',i
2698 cd        write(iout,*) 'B1',B1(:,i)
2699 cd        write(iout,*) 'B2',B2(:,i)
2700 cd        write(iout,*) 'CC',CC(:,:,i)
2701 cd        write(iout,*) 'DD',DD(:,:,i)
2702 cd        write(iout,*) 'EE',EE(:,:,i)
2703 cd      enddo
2704 cd      call check_vecgrad
2705 cd      stop
2706       if (icheckgrad.eq.1) then
2707         do i=1,nres-1
2708           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2709           do k=1,3
2710             dc_norm(k,i)=dc(k,i)*fac
2711           enddo
2712 c          write (iout,*) 'i',i,' fac',fac
2713         enddo
2714       endif
2715       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2716      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2717      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2718 c        call vec_and_deriv
2719 #ifdef TIMING
2720         time01=MPI_Wtime()
2721 #endif
2722         call set_matrices
2723 #ifdef TIMING
2724         time_mat=time_mat+MPI_Wtime()-time01
2725 #endif
2726       endif
2727 cd      do i=1,nres-1
2728 cd        write (iout,*) 'i=',i
2729 cd        do k=1,3
2730 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2731 cd        enddo
2732 cd        do k=1,3
2733 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2734 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2735 cd        enddo
2736 cd      enddo
2737       t_eelecij=0.0d0
2738       ees=0.0D0
2739       evdw1=0.0D0
2740       eel_loc=0.0d0
2741       eello_turn3=0.0d0
2742       eello_turn4=0.0d0
2743       ind=0
2744       do i=1,nres
2745         num_cont_hb(i)=0
2746       enddo
2747 cd      print '(a)','Enter EELEC'
2748 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2749       do i=1,nres
2750         gel_loc_loc(i)=0.0d0
2751         gcorr_loc(i)=0.0d0
2752       enddo
2753 c
2754 c
2755 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2756 C
2757 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2758 C
2759       do i=iturn3_start,iturn3_end
2760         if (itype(i).eq.21 .or. itype(i+1).eq.21
2761      &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21) cycle
2762         dxi=dc(1,i)
2763         dyi=dc(2,i)
2764         dzi=dc(3,i)
2765         dx_normi=dc_norm(1,i)
2766         dy_normi=dc_norm(2,i)
2767         dz_normi=dc_norm(3,i)
2768         xmedi=c(1,i)+0.5d0*dxi
2769         ymedi=c(2,i)+0.5d0*dyi
2770         zmedi=c(3,i)+0.5d0*dzi
2771         num_conti=0
2772         call eelecij(i,i+2,ees,evdw1,eel_loc)
2773         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2774         num_cont_hb(i)=num_conti
2775       enddo
2776       do i=iturn4_start,iturn4_end
2777         if (itype(i).eq.21 .or. itype(i+1).eq.21
2778      &    .or. itype(i+3).eq.21
2779      &    .or. itype(i+4).eq.21) cycle
2780         dxi=dc(1,i)
2781         dyi=dc(2,i)
2782         dzi=dc(3,i)
2783         dx_normi=dc_norm(1,i)
2784         dy_normi=dc_norm(2,i)
2785         dz_normi=dc_norm(3,i)
2786         xmedi=c(1,i)+0.5d0*dxi
2787         ymedi=c(2,i)+0.5d0*dyi
2788         zmedi=c(3,i)+0.5d0*dzi
2789         num_conti=num_cont_hb(i)
2790         call eelecij(i,i+3,ees,evdw1,eel_loc)
2791         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.21)
2792      &   call eturn4(i,eello_turn4)
2793         num_cont_hb(i)=num_conti
2794       enddo   ! i
2795 c
2796 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2797 c
2798       do i=iatel_s,iatel_e
2799         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
2800         dxi=dc(1,i)
2801         dyi=dc(2,i)
2802         dzi=dc(3,i)
2803         dx_normi=dc_norm(1,i)
2804         dy_normi=dc_norm(2,i)
2805         dz_normi=dc_norm(3,i)
2806         xmedi=c(1,i)+0.5d0*dxi
2807         ymedi=c(2,i)+0.5d0*dyi
2808         zmedi=c(3,i)+0.5d0*dzi
2809 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2810         num_conti=num_cont_hb(i)
2811         do j=ielstart(i),ielend(i)
2812 c          write (iout,*) i,j,itype(i),itype(j)
2813           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
2814           call eelecij(i,j,ees,evdw1,eel_loc)
2815         enddo ! j
2816         num_cont_hb(i)=num_conti
2817       enddo   ! i
2818 c      write (iout,*) "Number of loop steps in EELEC:",ind
2819 cd      do i=1,nres
2820 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2821 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2822 cd      enddo
2823 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2824 ccc      eel_loc=eel_loc+eello_turn3
2825 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2826       return
2827       end
2828 C-------------------------------------------------------------------------------
2829       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2830       implicit real*8 (a-h,o-z)
2831       include 'DIMENSIONS'
2832 #ifdef MPI
2833       include "mpif.h"
2834 #endif
2835       include 'COMMON.CONTROL'
2836       include 'COMMON.IOUNITS'
2837       include 'COMMON.GEO'
2838       include 'COMMON.VAR'
2839       include 'COMMON.LOCAL'
2840       include 'COMMON.CHAIN'
2841       include 'COMMON.DERIV'
2842       include 'COMMON.INTERACT'
2843       include 'COMMON.CONTACTS'
2844       include 'COMMON.TORSION'
2845       include 'COMMON.VECTORS'
2846       include 'COMMON.FFIELD'
2847       include 'COMMON.TIME1'
2848       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2849      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2850       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2851      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2852       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2853      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2854      &    num_conti,j1,j2
2855 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2856 #ifdef MOMENT
2857       double precision scal_el /1.0d0/
2858 #else
2859       double precision scal_el /0.5d0/
2860 #endif
2861 C 12/13/98
2862 C 13-go grudnia roku pamietnego...
2863       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2864      &                   0.0d0,1.0d0,0.0d0,
2865      &                   0.0d0,0.0d0,1.0d0/
2866 c          time00=MPI_Wtime()
2867 cd      write (iout,*) "eelecij",i,j
2868 c          ind=ind+1
2869           iteli=itel(i)
2870           itelj=itel(j)
2871           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2872           aaa=app(iteli,itelj)
2873           bbb=bpp(iteli,itelj)
2874           ael6i=ael6(iteli,itelj)
2875           ael3i=ael3(iteli,itelj)
2876           dxj=dc(1,j)
2877           dyj=dc(2,j)
2878           dzj=dc(3,j)
2879           dx_normj=dc_norm(1,j)
2880           dy_normj=dc_norm(2,j)
2881           dz_normj=dc_norm(3,j)
2882           xj=c(1,j)+0.5D0*dxj-xmedi
2883           yj=c(2,j)+0.5D0*dyj-ymedi
2884           zj=c(3,j)+0.5D0*dzj-zmedi
2885           rij=xj*xj+yj*yj+zj*zj
2886           rrmij=1.0D0/rij
2887           rij=dsqrt(rij)
2888           rmij=1.0D0/rij
2889           r3ij=rrmij*rmij
2890           r6ij=r3ij*r3ij
2891           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2892           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2893           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2894           fac=cosa-3.0D0*cosb*cosg
2895           ev1=aaa*r6ij*r6ij
2896 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2897           if (j.eq.i+2) ev1=scal_el*ev1
2898           ev2=bbb*r6ij
2899           fac3=ael6i*r6ij
2900           fac4=ael3i*r3ij
2901           evdwij=ev1+ev2
2902           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2903           el2=fac4*fac
2904           eesij=el1+el2
2905 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2906           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2907           ees=ees+eesij
2908           evdw1=evdw1+evdwij
2909 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2910 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2911 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2912 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2913
2914           if (energy_dec) then
2915               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2916               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2917           endif
2918
2919 C
2920 C Calculate contributions to the Cartesian gradient.
2921 C
2922 #ifdef SPLITELE
2923           facvdw=-6*rrmij*(ev1+evdwij)
2924           facel=-3*rrmij*(el1+eesij)
2925           fac1=fac
2926           erij(1)=xj*rmij
2927           erij(2)=yj*rmij
2928           erij(3)=zj*rmij
2929 *
2930 * Radial derivatives. First process both termini of the fragment (i,j)
2931 *
2932           ggg(1)=facel*xj
2933           ggg(2)=facel*yj
2934           ggg(3)=facel*zj
2935 c          do k=1,3
2936 c            ghalf=0.5D0*ggg(k)
2937 c            gelc(k,i)=gelc(k,i)+ghalf
2938 c            gelc(k,j)=gelc(k,j)+ghalf
2939 c          enddo
2940 c 9/28/08 AL Gradient compotents will be summed only at the end
2941           do k=1,3
2942             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2943             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2944           enddo
2945 *
2946 * Loop over residues i+1 thru j-1.
2947 *
2948 cgrad          do k=i+1,j-1
2949 cgrad            do l=1,3
2950 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2951 cgrad            enddo
2952 cgrad          enddo
2953           ggg(1)=facvdw*xj
2954           ggg(2)=facvdw*yj
2955           ggg(3)=facvdw*zj
2956 c          do k=1,3
2957 c            ghalf=0.5D0*ggg(k)
2958 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2959 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2960 c          enddo
2961 c 9/28/08 AL Gradient compotents will be summed only at the end
2962           do k=1,3
2963             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2964             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2965           enddo
2966 *
2967 * Loop over residues i+1 thru j-1.
2968 *
2969 cgrad          do k=i+1,j-1
2970 cgrad            do l=1,3
2971 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2972 cgrad            enddo
2973 cgrad          enddo
2974 #else
2975           facvdw=ev1+evdwij
2976           facel=el1+eesij
2977           fac1=fac
2978           fac=-3*rrmij*(facvdw+facvdw+facel)
2979           erij(1)=xj*rmij
2980           erij(2)=yj*rmij
2981           erij(3)=zj*rmij
2982 *
2983 * Radial derivatives. First process both termini of the fragment (i,j)
2984 *
2985           ggg(1)=fac*xj
2986           ggg(2)=fac*yj
2987           ggg(3)=fac*zj
2988 c          do k=1,3
2989 c            ghalf=0.5D0*ggg(k)
2990 c            gelc(k,i)=gelc(k,i)+ghalf
2991 c            gelc(k,j)=gelc(k,j)+ghalf
2992 c          enddo
2993 c 9/28/08 AL Gradient compotents will be summed only at the end
2994           do k=1,3
2995             gelc_long(k,j)=gelc(k,j)+ggg(k)
2996             gelc_long(k,i)=gelc(k,i)-ggg(k)
2997           enddo
2998 *
2999 * Loop over residues i+1 thru j-1.
3000 *
3001 cgrad          do k=i+1,j-1
3002 cgrad            do l=1,3
3003 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3004 cgrad            enddo
3005 cgrad          enddo
3006 c 9/28/08 AL Gradient compotents will be summed only at the end
3007           ggg(1)=facvdw*xj
3008           ggg(2)=facvdw*yj
3009           ggg(3)=facvdw*zj
3010           do k=1,3
3011             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3012             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3013           enddo
3014 #endif
3015 *
3016 * Angular part
3017 *
3018           ecosa=2.0D0*fac3*fac1+fac4
3019           fac4=-3.0D0*fac4
3020           fac3=-6.0D0*fac3
3021           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3022           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3023           do k=1,3
3024             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3025             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3026           enddo
3027 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3028 cd   &          (dcosg(k),k=1,3)
3029           do k=1,3
3030             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3031           enddo
3032 c          do k=1,3
3033 c            ghalf=0.5D0*ggg(k)
3034 c            gelc(k,i)=gelc(k,i)+ghalf
3035 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3036 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3037 c            gelc(k,j)=gelc(k,j)+ghalf
3038 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3039 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3040 c          enddo
3041 cgrad          do k=i+1,j-1
3042 cgrad            do l=1,3
3043 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3044 cgrad            enddo
3045 cgrad          enddo
3046           do k=1,3
3047             gelc(k,i)=gelc(k,i)
3048      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3049      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3050             gelc(k,j)=gelc(k,j)
3051      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3052      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3053             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3054             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3055           enddo
3056           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3057      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3058      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3059 C
3060 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3061 C   energy of a peptide unit is assumed in the form of a second-order
3062 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3063 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3064 C   are computed for EVERY pair of non-contiguous peptide groups.
3065 C
3066           if (j.lt.nres-1) then
3067             j1=j+1
3068             j2=j-1
3069           else
3070             j1=j-1
3071             j2=j-2
3072           endif
3073           kkk=0
3074           do k=1,2
3075             do l=1,2
3076               kkk=kkk+1
3077               muij(kkk)=mu(k,i)*mu(l,j)
3078             enddo
3079           enddo
3080 cd         write (iout,*) 'EELEC: i',i,' j',j
3081 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3082 cd          write(iout,*) 'muij',muij
3083           ury=scalar(uy(1,i),erij)
3084           urz=scalar(uz(1,i),erij)
3085           vry=scalar(uy(1,j),erij)
3086           vrz=scalar(uz(1,j),erij)
3087           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3088           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3089           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3090           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3091           fac=dsqrt(-ael6i)*r3ij
3092           a22=a22*fac
3093           a23=a23*fac
3094           a32=a32*fac
3095           a33=a33*fac
3096 cd          write (iout,'(4i5,4f10.5)')
3097 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3098 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3099 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3100 cd     &      uy(:,j),uz(:,j)
3101 cd          write (iout,'(4f10.5)')
3102 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3103 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3104 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3105 cd           write (iout,'(9f10.5/)')
3106 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3107 C Derivatives of the elements of A in virtual-bond vectors
3108           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3109           do k=1,3
3110             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3111             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3112             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3113             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3114             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3115             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3116             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3117             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3118             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3119             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3120             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3121             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3122           enddo
3123 C Compute radial contributions to the gradient
3124           facr=-3.0d0*rrmij
3125           a22der=a22*facr
3126           a23der=a23*facr
3127           a32der=a32*facr
3128           a33der=a33*facr
3129           agg(1,1)=a22der*xj
3130           agg(2,1)=a22der*yj
3131           agg(3,1)=a22der*zj
3132           agg(1,2)=a23der*xj
3133           agg(2,2)=a23der*yj
3134           agg(3,2)=a23der*zj
3135           agg(1,3)=a32der*xj
3136           agg(2,3)=a32der*yj
3137           agg(3,3)=a32der*zj
3138           agg(1,4)=a33der*xj
3139           agg(2,4)=a33der*yj
3140           agg(3,4)=a33der*zj
3141 C Add the contributions coming from er
3142           fac3=-3.0d0*fac
3143           do k=1,3
3144             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3145             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3146             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3147             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3148           enddo
3149           do k=1,3
3150 C Derivatives in DC(i)
3151 cgrad            ghalf1=0.5d0*agg(k,1)
3152 cgrad            ghalf2=0.5d0*agg(k,2)
3153 cgrad            ghalf3=0.5d0*agg(k,3)
3154 cgrad            ghalf4=0.5d0*agg(k,4)
3155             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3156      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3157             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3158      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3159             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3160      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3161             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3162      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3163 C Derivatives in DC(i+1)
3164             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3165      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3166             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3167      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3168             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3169      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3170             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3171      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3172 C Derivatives in DC(j)
3173             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3174      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3175             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3176      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3177             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3178      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3179             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3180      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3181 C Derivatives in DC(j+1) or DC(nres-1)
3182             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3183      &      -3.0d0*vryg(k,3)*ury)
3184             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3185      &      -3.0d0*vrzg(k,3)*ury)
3186             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3187      &      -3.0d0*vryg(k,3)*urz)
3188             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3189      &      -3.0d0*vrzg(k,3)*urz)
3190 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3191 cgrad              do l=1,4
3192 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3193 cgrad              enddo
3194 cgrad            endif
3195           enddo
3196           acipa(1,1)=a22
3197           acipa(1,2)=a23
3198           acipa(2,1)=a32
3199           acipa(2,2)=a33
3200           a22=-a22
3201           a23=-a23
3202           do l=1,2
3203             do k=1,3
3204               agg(k,l)=-agg(k,l)
3205               aggi(k,l)=-aggi(k,l)
3206               aggi1(k,l)=-aggi1(k,l)
3207               aggj(k,l)=-aggj(k,l)
3208               aggj1(k,l)=-aggj1(k,l)
3209             enddo
3210           enddo
3211           if (j.lt.nres-1) then
3212             a22=-a22
3213             a32=-a32
3214             do l=1,3,2
3215               do k=1,3
3216                 agg(k,l)=-agg(k,l)
3217                 aggi(k,l)=-aggi(k,l)
3218                 aggi1(k,l)=-aggi1(k,l)
3219                 aggj(k,l)=-aggj(k,l)
3220                 aggj1(k,l)=-aggj1(k,l)
3221               enddo
3222             enddo
3223           else
3224             a22=-a22
3225             a23=-a23
3226             a32=-a32
3227             a33=-a33
3228             do l=1,4
3229               do k=1,3
3230                 agg(k,l)=-agg(k,l)
3231                 aggi(k,l)=-aggi(k,l)
3232                 aggi1(k,l)=-aggi1(k,l)
3233                 aggj(k,l)=-aggj(k,l)
3234                 aggj1(k,l)=-aggj1(k,l)
3235               enddo
3236             enddo
3237           endif
3238           ENDIF ! WCORR
3239           IF (wel_loc.gt.0.0d0) THEN
3240 C Contribution to the local-electrostatic energy coming from the i-j pair
3241           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3242      &     +a33*muij(4)
3243 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3244
3245           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3246      &            'eelloc',i,j,eel_loc_ij
3247
3248           eel_loc=eel_loc+eel_loc_ij
3249 C Partial derivatives in virtual-bond dihedral angles gamma
3250           if (i.gt.1)
3251      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3252      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3253      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3254           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3255      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3256      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3257 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3258           do l=1,3
3259             ggg(l)=agg(l,1)*muij(1)+
3260      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3261             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3262             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3263 cgrad            ghalf=0.5d0*ggg(l)
3264 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3265 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3266           enddo
3267 cgrad          do k=i+1,j2
3268 cgrad            do l=1,3
3269 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3270 cgrad            enddo
3271 cgrad          enddo
3272 C Remaining derivatives of eello
3273           do l=1,3
3274             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3275      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3276             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3277      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3278             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3279      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3280             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3281      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3282           enddo
3283           ENDIF
3284 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3285 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3286           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3287      &       .and. num_conti.le.maxconts) then
3288 c            write (iout,*) i,j," entered corr"
3289 C
3290 C Calculate the contact function. The ith column of the array JCONT will
3291 C contain the numbers of atoms that make contacts with the atom I (of numbers
3292 C greater than I). The arrays FACONT and GACONT will contain the values of
3293 C the contact function and its derivative.
3294 c           r0ij=1.02D0*rpp(iteli,itelj)
3295 c           r0ij=1.11D0*rpp(iteli,itelj)
3296             r0ij=2.20D0*rpp(iteli,itelj)
3297 c           r0ij=1.55D0*rpp(iteli,itelj)
3298             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3299             if (fcont.gt.0.0D0) then
3300               num_conti=num_conti+1
3301               if (num_conti.gt.maxconts) then
3302                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3303      &                         ' will skip next contacts for this conf.'
3304               else
3305                 jcont_hb(num_conti,i)=j
3306 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3307 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3308                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3309      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3310 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3311 C  terms.
3312                 d_cont(num_conti,i)=rij
3313 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3314 C     --- Electrostatic-interaction matrix ---
3315                 a_chuj(1,1,num_conti,i)=a22
3316                 a_chuj(1,2,num_conti,i)=a23
3317                 a_chuj(2,1,num_conti,i)=a32
3318                 a_chuj(2,2,num_conti,i)=a33
3319 C     --- Gradient of rij
3320                 do kkk=1,3
3321                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3322                 enddo
3323                 kkll=0
3324                 do k=1,2
3325                   do l=1,2
3326                     kkll=kkll+1
3327                     do m=1,3
3328                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3329                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3330                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3331                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3332                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3333                     enddo
3334                   enddo
3335                 enddo
3336                 ENDIF
3337                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3338 C Calculate contact energies
3339                 cosa4=4.0D0*cosa
3340                 wij=cosa-3.0D0*cosb*cosg
3341                 cosbg1=cosb+cosg
3342                 cosbg2=cosb-cosg
3343 c               fac3=dsqrt(-ael6i)/r0ij**3
3344                 fac3=dsqrt(-ael6i)*r3ij
3345 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3346                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3347                 if (ees0tmp.gt.0) then
3348                   ees0pij=dsqrt(ees0tmp)
3349                 else
3350                   ees0pij=0
3351                 endif
3352 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3353                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3354                 if (ees0tmp.gt.0) then
3355                   ees0mij=dsqrt(ees0tmp)
3356                 else
3357                   ees0mij=0
3358                 endif
3359 c               ees0mij=0.0D0
3360                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3361                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3362 C Diagnostics. Comment out or remove after debugging!
3363 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3364 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3365 c               ees0m(num_conti,i)=0.0D0
3366 C End diagnostics.
3367 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3368 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3369 C Angular derivatives of the contact function
3370                 ees0pij1=fac3/ees0pij
3371                 ees0mij1=fac3/ees0mij
3372                 fac3p=-3.0D0*fac3*rrmij
3373                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3374                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3375 c               ees0mij1=0.0D0
3376                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3377                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3378                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3379                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3380                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3381                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3382                 ecosap=ecosa1+ecosa2
3383                 ecosbp=ecosb1+ecosb2
3384                 ecosgp=ecosg1+ecosg2
3385                 ecosam=ecosa1-ecosa2
3386                 ecosbm=ecosb1-ecosb2
3387                 ecosgm=ecosg1-ecosg2
3388 C Diagnostics
3389 c               ecosap=ecosa1
3390 c               ecosbp=ecosb1
3391 c               ecosgp=ecosg1
3392 c               ecosam=0.0D0
3393 c               ecosbm=0.0D0
3394 c               ecosgm=0.0D0
3395 C End diagnostics
3396                 facont_hb(num_conti,i)=fcont
3397                 fprimcont=fprimcont/rij
3398 cd              facont_hb(num_conti,i)=1.0D0
3399 C Following line is for diagnostics.
3400 cd              fprimcont=0.0D0
3401                 do k=1,3
3402                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3403                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3404                 enddo
3405                 do k=1,3
3406                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3407                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3408                 enddo
3409                 gggp(1)=gggp(1)+ees0pijp*xj
3410                 gggp(2)=gggp(2)+ees0pijp*yj
3411                 gggp(3)=gggp(3)+ees0pijp*zj
3412                 gggm(1)=gggm(1)+ees0mijp*xj
3413                 gggm(2)=gggm(2)+ees0mijp*yj
3414                 gggm(3)=gggm(3)+ees0mijp*zj
3415 C Derivatives due to the contact function
3416                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3417                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3418                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3419                 do k=1,3
3420 c
3421 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3422 c          following the change of gradient-summation algorithm.
3423 c
3424 cgrad                  ghalfp=0.5D0*gggp(k)
3425 cgrad                  ghalfm=0.5D0*gggm(k)
3426                   gacontp_hb1(k,num_conti,i)=!ghalfp
3427      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3428      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3429                   gacontp_hb2(k,num_conti,i)=!ghalfp
3430      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3431      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3432                   gacontp_hb3(k,num_conti,i)=gggp(k)
3433                   gacontm_hb1(k,num_conti,i)=!ghalfm
3434      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3435      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3436                   gacontm_hb2(k,num_conti,i)=!ghalfm
3437      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3438      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3439                   gacontm_hb3(k,num_conti,i)=gggm(k)
3440                 enddo
3441 C Diagnostics. Comment out or remove after debugging!
3442 cdiag           do k=1,3
3443 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3444 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3445 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3446 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3447 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3448 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3449 cdiag           enddo
3450               ENDIF ! wcorr
3451               endif  ! num_conti.le.maxconts
3452             endif  ! fcont.gt.0
3453           endif    ! j.gt.i+1
3454           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3455             do k=1,4
3456               do l=1,3
3457                 ghalf=0.5d0*agg(l,k)
3458                 aggi(l,k)=aggi(l,k)+ghalf
3459                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3460                 aggj(l,k)=aggj(l,k)+ghalf
3461               enddo
3462             enddo
3463             if (j.eq.nres-1 .and. i.lt.j-2) then
3464               do k=1,4
3465                 do l=1,3
3466                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3467                 enddo
3468               enddo
3469             endif
3470           endif
3471 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3472       return
3473       end
3474 C-----------------------------------------------------------------------------
3475       subroutine eturn3(i,eello_turn3)
3476 C Third- and fourth-order contributions from turns
3477       implicit real*8 (a-h,o-z)
3478       include 'DIMENSIONS'
3479       include 'COMMON.IOUNITS'
3480       include 'COMMON.GEO'
3481       include 'COMMON.VAR'
3482       include 'COMMON.LOCAL'
3483       include 'COMMON.CHAIN'
3484       include 'COMMON.DERIV'
3485       include 'COMMON.INTERACT'
3486       include 'COMMON.CONTACTS'
3487       include 'COMMON.TORSION'
3488       include 'COMMON.VECTORS'
3489       include 'COMMON.FFIELD'
3490       include 'COMMON.CONTROL'
3491       dimension ggg(3)
3492       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3493      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3494      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3495       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3496      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3497       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3498      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3499      &    num_conti,j1,j2
3500       j=i+2
3501 c      write (iout,*) "eturn3",i,j,j1,j2
3502       a_temp(1,1)=a22
3503       a_temp(1,2)=a23
3504       a_temp(2,1)=a32
3505       a_temp(2,2)=a33
3506 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3507 C
3508 C               Third-order contributions
3509 C
3510 C                 (i+2)o----(i+3)
3511 C                      | |
3512 C                      | |
3513 C                 (i+1)o----i
3514 C
3515 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3516 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3517         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3518         call transpose2(auxmat(1,1),auxmat1(1,1))
3519         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3520         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3521         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3522      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3523 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3524 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3525 cd     &    ' eello_turn3_num',4*eello_turn3_num
3526 C Derivatives in gamma(i)
3527         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3528         call transpose2(auxmat2(1,1),auxmat3(1,1))
3529         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3530         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3531 C Derivatives in gamma(i+1)
3532         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3533         call transpose2(auxmat2(1,1),auxmat3(1,1))
3534         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3535         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3536      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3537 C Cartesian derivatives
3538         do l=1,3
3539 c            ghalf1=0.5d0*agg(l,1)
3540 c            ghalf2=0.5d0*agg(l,2)
3541 c            ghalf3=0.5d0*agg(l,3)
3542 c            ghalf4=0.5d0*agg(l,4)
3543           a_temp(1,1)=aggi(l,1)!+ghalf1
3544           a_temp(1,2)=aggi(l,2)!+ghalf2
3545           a_temp(2,1)=aggi(l,3)!+ghalf3
3546           a_temp(2,2)=aggi(l,4)!+ghalf4
3547           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3548           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3549      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3550           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3551           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3552           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3553           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3554           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3555           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3556      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3557           a_temp(1,1)=aggj(l,1)!+ghalf1
3558           a_temp(1,2)=aggj(l,2)!+ghalf2
3559           a_temp(2,1)=aggj(l,3)!+ghalf3
3560           a_temp(2,2)=aggj(l,4)!+ghalf4
3561           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3562           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3563      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3564           a_temp(1,1)=aggj1(l,1)
3565           a_temp(1,2)=aggj1(l,2)
3566           a_temp(2,1)=aggj1(l,3)
3567           a_temp(2,2)=aggj1(l,4)
3568           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3569           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3570      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3571         enddo
3572       return
3573       end
3574 C-------------------------------------------------------------------------------
3575       subroutine eturn4(i,eello_turn4)
3576 C Third- and fourth-order contributions from turns
3577       implicit real*8 (a-h,o-z)
3578       include 'DIMENSIONS'
3579       include 'COMMON.IOUNITS'
3580       include 'COMMON.GEO'
3581       include 'COMMON.VAR'
3582       include 'COMMON.LOCAL'
3583       include 'COMMON.CHAIN'
3584       include 'COMMON.DERIV'
3585       include 'COMMON.INTERACT'
3586       include 'COMMON.CONTACTS'
3587       include 'COMMON.TORSION'
3588       include 'COMMON.VECTORS'
3589       include 'COMMON.FFIELD'
3590       include 'COMMON.CONTROL'
3591       dimension ggg(3)
3592       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3593      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3594      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3595       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3596      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3597       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3598      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3599      &    num_conti,j1,j2
3600       j=i+3
3601 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3602 C
3603 C               Fourth-order contributions
3604 C
3605 C                 (i+3)o----(i+4)
3606 C                     /  |
3607 C               (i+2)o   |
3608 C                     \  |
3609 C                 (i+1)o----i
3610 C
3611 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3612 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3613 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3614         a_temp(1,1)=a22
3615         a_temp(1,2)=a23
3616         a_temp(2,1)=a32
3617         a_temp(2,2)=a33
3618         iti1=itortyp(itype(i+1))
3619         iti2=itortyp(itype(i+2))
3620         iti3=itortyp(itype(i+3))
3621 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3622         call transpose2(EUg(1,1,i+1),e1t(1,1))
3623         call transpose2(Eug(1,1,i+2),e2t(1,1))
3624         call transpose2(Eug(1,1,i+3),e3t(1,1))
3625         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3626         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3627         s1=scalar2(b1(1,iti2),auxvec(1))
3628         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3629         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3630         s2=scalar2(b1(1,iti1),auxvec(1))
3631         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3632         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3633         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3634         eello_turn4=eello_turn4-(s1+s2+s3)
3635         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3636      &      'eturn4',i,j,-(s1+s2+s3)
3637 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3638 cd     &    ' eello_turn4_num',8*eello_turn4_num
3639 C Derivatives in gamma(i)
3640         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3641         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3642         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3643         s1=scalar2(b1(1,iti2),auxvec(1))
3644         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3645         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3646         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3647 C Derivatives in gamma(i+1)
3648         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3649         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3650         s2=scalar2(b1(1,iti1),auxvec(1))
3651         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3652         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3653         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3654         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3655 C Derivatives in gamma(i+2)
3656         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3657         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3658         s1=scalar2(b1(1,iti2),auxvec(1))
3659         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3660         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3661         s2=scalar2(b1(1,iti1),auxvec(1))
3662         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3663         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3664         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3665         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3666 C Cartesian derivatives
3667 C Derivatives of this turn contributions in DC(i+2)
3668         if (j.lt.nres-1) then
3669           do l=1,3
3670             a_temp(1,1)=agg(l,1)
3671             a_temp(1,2)=agg(l,2)
3672             a_temp(2,1)=agg(l,3)
3673             a_temp(2,2)=agg(l,4)
3674             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3675             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3676             s1=scalar2(b1(1,iti2),auxvec(1))
3677             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3678             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3679             s2=scalar2(b1(1,iti1),auxvec(1))
3680             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3681             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3682             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3683             ggg(l)=-(s1+s2+s3)
3684             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3685           enddo
3686         endif
3687 C Remaining derivatives of this turn contribution
3688         do l=1,3
3689           a_temp(1,1)=aggi(l,1)
3690           a_temp(1,2)=aggi(l,2)
3691           a_temp(2,1)=aggi(l,3)
3692           a_temp(2,2)=aggi(l,4)
3693           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3694           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3695           s1=scalar2(b1(1,iti2),auxvec(1))
3696           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3697           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3698           s2=scalar2(b1(1,iti1),auxvec(1))
3699           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3700           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3701           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3702           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3703           a_temp(1,1)=aggi1(l,1)
3704           a_temp(1,2)=aggi1(l,2)
3705           a_temp(2,1)=aggi1(l,3)
3706           a_temp(2,2)=aggi1(l,4)
3707           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3708           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3709           s1=scalar2(b1(1,iti2),auxvec(1))
3710           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3711           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3712           s2=scalar2(b1(1,iti1),auxvec(1))
3713           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3714           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3715           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3716           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3717           a_temp(1,1)=aggj(l,1)
3718           a_temp(1,2)=aggj(l,2)
3719           a_temp(2,1)=aggj(l,3)
3720           a_temp(2,2)=aggj(l,4)
3721           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3722           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3723           s1=scalar2(b1(1,iti2),auxvec(1))
3724           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3725           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3726           s2=scalar2(b1(1,iti1),auxvec(1))
3727           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3728           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3729           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3730           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3731           a_temp(1,1)=aggj1(l,1)
3732           a_temp(1,2)=aggj1(l,2)
3733           a_temp(2,1)=aggj1(l,3)
3734           a_temp(2,2)=aggj1(l,4)
3735           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3736           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3737           s1=scalar2(b1(1,iti2),auxvec(1))
3738           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3739           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3740           s2=scalar2(b1(1,iti1),auxvec(1))
3741           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3742           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3743           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3744 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3745           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3746         enddo
3747       return
3748       end
3749 C-----------------------------------------------------------------------------
3750       subroutine vecpr(u,v,w)
3751       implicit real*8(a-h,o-z)
3752       dimension u(3),v(3),w(3)
3753       w(1)=u(2)*v(3)-u(3)*v(2)
3754       w(2)=-u(1)*v(3)+u(3)*v(1)
3755       w(3)=u(1)*v(2)-u(2)*v(1)
3756       return
3757       end
3758 C-----------------------------------------------------------------------------
3759       subroutine unormderiv(u,ugrad,unorm,ungrad)
3760 C This subroutine computes the derivatives of a normalized vector u, given
3761 C the derivatives computed without normalization conditions, ugrad. Returns
3762 C ungrad.
3763       implicit none
3764       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3765       double precision vec(3)
3766       double precision scalar
3767       integer i,j
3768 c      write (2,*) 'ugrad',ugrad
3769 c      write (2,*) 'u',u
3770       do i=1,3
3771         vec(i)=scalar(ugrad(1,i),u(1))
3772       enddo
3773 c      write (2,*) 'vec',vec
3774       do i=1,3
3775         do j=1,3
3776           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3777         enddo
3778       enddo
3779 c      write (2,*) 'ungrad',ungrad
3780       return
3781       end
3782 C-----------------------------------------------------------------------------
3783       subroutine escp_soft_sphere(evdw2,evdw2_14)
3784 C
3785 C This subroutine calculates the excluded-volume interaction energy between
3786 C peptide-group centers and side chains and its gradient in virtual-bond and
3787 C side-chain vectors.
3788 C
3789       implicit real*8 (a-h,o-z)
3790       include 'DIMENSIONS'
3791       include 'COMMON.GEO'
3792       include 'COMMON.VAR'
3793       include 'COMMON.LOCAL'
3794       include 'COMMON.CHAIN'
3795       include 'COMMON.DERIV'
3796       include 'COMMON.INTERACT'
3797       include 'COMMON.FFIELD'
3798       include 'COMMON.IOUNITS'
3799       include 'COMMON.CONTROL'
3800       dimension ggg(3)
3801       evdw2=0.0D0
3802       evdw2_14=0.0d0
3803       r0_scp=4.5d0
3804 cd    print '(a)','Enter ESCP'
3805 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3806       do i=iatscp_s,iatscp_e
3807         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3808         iteli=itel(i)
3809         xi=0.5D0*(c(1,i)+c(1,i+1))
3810         yi=0.5D0*(c(2,i)+c(2,i+1))
3811         zi=0.5D0*(c(3,i)+c(3,i+1))
3812
3813         do iint=1,nscp_gr(i)
3814
3815         do j=iscpstart(i,iint),iscpend(i,iint)
3816           if (itype(j).eq.21) cycle
3817           itypj=itype(j)
3818 C Uncomment following three lines for SC-p interactions
3819 c         xj=c(1,nres+j)-xi
3820 c         yj=c(2,nres+j)-yi
3821 c         zj=c(3,nres+j)-zi
3822 C Uncomment following three lines for Ca-p interactions
3823           xj=c(1,j)-xi
3824           yj=c(2,j)-yi
3825           zj=c(3,j)-zi
3826           rij=xj*xj+yj*yj+zj*zj
3827           r0ij=r0_scp
3828           r0ijsq=r0ij*r0ij
3829           if (rij.lt.r0ijsq) then
3830             evdwij=0.25d0*(rij-r0ijsq)**2
3831             fac=rij-r0ijsq
3832           else
3833             evdwij=0.0d0
3834             fac=0.0d0
3835           endif
3836           evdw2=evdw2+evdwij
3837 C
3838 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3839 C
3840           ggg(1)=xj*fac
3841           ggg(2)=yj*fac
3842           ggg(3)=zj*fac
3843 cgrad          if (j.lt.i) then
3844 cd          write (iout,*) 'j<i'
3845 C Uncomment following three lines for SC-p interactions
3846 c           do k=1,3
3847 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3848 c           enddo
3849 cgrad          else
3850 cd          write (iout,*) 'j>i'
3851 cgrad            do k=1,3
3852 cgrad              ggg(k)=-ggg(k)
3853 C Uncomment following line for SC-p interactions
3854 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3855 cgrad            enddo
3856 cgrad          endif
3857 cgrad          do k=1,3
3858 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3859 cgrad          enddo
3860 cgrad          kstart=min0(i+1,j)
3861 cgrad          kend=max0(i-1,j-1)
3862 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3863 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3864 cgrad          do k=kstart,kend
3865 cgrad            do l=1,3
3866 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3867 cgrad            enddo
3868 cgrad          enddo
3869           do k=1,3
3870             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3871             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3872           enddo
3873         enddo
3874
3875         enddo ! iint
3876       enddo ! i
3877       return
3878       end
3879 C-----------------------------------------------------------------------------
3880       subroutine escp(evdw2,evdw2_14)
3881 C
3882 C This subroutine calculates the excluded-volume interaction energy between
3883 C peptide-group centers and side chains and its gradient in virtual-bond and
3884 C side-chain vectors.
3885 C
3886       implicit real*8 (a-h,o-z)
3887       include 'DIMENSIONS'
3888       include 'COMMON.GEO'
3889       include 'COMMON.VAR'
3890       include 'COMMON.LOCAL'
3891       include 'COMMON.CHAIN'
3892       include 'COMMON.DERIV'
3893       include 'COMMON.INTERACT'
3894       include 'COMMON.FFIELD'
3895       include 'COMMON.IOUNITS'
3896       include 'COMMON.CONTROL'
3897       dimension ggg(3)
3898       evdw2=0.0D0
3899       evdw2_14=0.0d0
3900 cd    print '(a)','Enter ESCP'
3901 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3902       do i=iatscp_s,iatscp_e
3903         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3904         iteli=itel(i)
3905         xi=0.5D0*(c(1,i)+c(1,i+1))
3906         yi=0.5D0*(c(2,i)+c(2,i+1))
3907         zi=0.5D0*(c(3,i)+c(3,i+1))
3908
3909         do iint=1,nscp_gr(i)
3910
3911         do j=iscpstart(i,iint),iscpend(i,iint)
3912           itypj=itype(j)
3913           if (itypj.eq.21) cycle
3914 C Uncomment following three lines for SC-p interactions
3915 c         xj=c(1,nres+j)-xi
3916 c         yj=c(2,nres+j)-yi
3917 c         zj=c(3,nres+j)-zi
3918 C Uncomment following three lines for Ca-p interactions
3919           xj=c(1,j)-xi
3920           yj=c(2,j)-yi
3921           zj=c(3,j)-zi
3922           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3923           fac=rrij**expon2
3924           e1=fac*fac*aad(itypj,iteli)
3925           e2=fac*bad(itypj,iteli)
3926           if (iabs(j-i) .le. 2) then
3927             e1=scal14*e1
3928             e2=scal14*e2
3929             evdw2_14=evdw2_14+e1+e2
3930           endif
3931           evdwij=e1+e2
3932           evdw2=evdw2+evdwij
3933           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3934      &        'evdw2',i,j,evdwij
3935 C
3936 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3937 C
3938           fac=-(evdwij+e1)*rrij
3939           ggg(1)=xj*fac
3940           ggg(2)=yj*fac
3941           ggg(3)=zj*fac
3942 cgrad          if (j.lt.i) then
3943 cd          write (iout,*) 'j<i'
3944 C Uncomment following three lines for SC-p interactions
3945 c           do k=1,3
3946 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3947 c           enddo
3948 cgrad          else
3949 cd          write (iout,*) 'j>i'
3950 cgrad            do k=1,3
3951 cgrad              ggg(k)=-ggg(k)
3952 C Uncomment following line for SC-p interactions
3953 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3954 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3955 cgrad            enddo
3956 cgrad          endif
3957 cgrad          do k=1,3
3958 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3959 cgrad          enddo
3960 cgrad          kstart=min0(i+1,j)
3961 cgrad          kend=max0(i-1,j-1)
3962 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3963 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3964 cgrad          do k=kstart,kend
3965 cgrad            do l=1,3
3966 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3967 cgrad            enddo
3968 cgrad          enddo
3969           do k=1,3
3970             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3971             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3972           enddo
3973         enddo
3974
3975         enddo ! iint
3976       enddo ! i
3977       do i=1,nct
3978         do j=1,3
3979           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3980           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3981           gradx_scp(j,i)=expon*gradx_scp(j,i)
3982         enddo
3983       enddo
3984 C******************************************************************************
3985 C
3986 C                              N O T E !!!
3987 C
3988 C To save time the factor EXPON has been extracted from ALL components
3989 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3990 C use!
3991 C
3992 C******************************************************************************
3993       return
3994       end
3995 C--------------------------------------------------------------------------
3996       subroutine edis(ehpb)
3997 C
3998 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3999 C
4000       implicit real*8 (a-h,o-z)
4001       include 'DIMENSIONS'
4002       include 'COMMON.SBRIDGE'
4003       include 'COMMON.CHAIN'
4004       include 'COMMON.DERIV'
4005       include 'COMMON.VAR'
4006       include 'COMMON.INTERACT'
4007       include 'COMMON.IOUNITS'
4008       dimension ggg(3)
4009       ehpb=0.0D0
4010 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4011 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4012       if (link_end.eq.0) return
4013       do i=link_start,link_end
4014 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4015 C CA-CA distance used in regularization of structure.
4016         ii=ihpb(i)
4017         jj=jhpb(i)
4018 C iii and jjj point to the residues for which the distance is assigned.
4019         if (ii.gt.nres) then
4020           iii=ii-nres
4021           jjj=jj-nres
4022         else
4023           iii=ii
4024           jjj=jj
4025         endif
4026 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4027 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4028 C    distance and angle dependent SS bond potential.
4029         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4030           call ssbond_ene(iii,jjj,eij)
4031           ehpb=ehpb+2*eij
4032 cd          write (iout,*) "eij",eij
4033         else
4034 C Calculate the distance between the two points and its difference from the
4035 C target distance.
4036         dd=dist(ii,jj)
4037         rdis=dd-dhpb(i)
4038 C Get the force constant corresponding to this distance.
4039         waga=forcon(i)
4040 C Calculate the contribution to energy.
4041         ehpb=ehpb+waga*rdis*rdis
4042 C
4043 C Evaluate gradient.
4044 C
4045         fac=waga*rdis/dd
4046 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4047 cd   &   ' waga=',waga,' fac=',fac
4048         do j=1,3
4049           ggg(j)=fac*(c(j,jj)-c(j,ii))
4050         enddo
4051 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4052 C If this is a SC-SC distance, we need to calculate the contributions to the
4053 C Cartesian gradient in the SC vectors (ghpbx).
4054         if (iii.lt.ii) then
4055           do j=1,3
4056             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4057             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4058           enddo
4059         endif
4060 cgrad        do j=iii,jjj-1
4061 cgrad          do k=1,3
4062 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4063 cgrad          enddo
4064 cgrad        enddo
4065         do k=1,3
4066           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4067           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4068         enddo
4069         endif
4070       enddo
4071       ehpb=0.5D0*ehpb
4072       return
4073       end
4074 C--------------------------------------------------------------------------
4075       subroutine ssbond_ene(i,j,eij)
4076 C
4077 C Calculate the distance and angle dependent SS-bond potential energy
4078 C using a free-energy function derived based on RHF/6-31G** ab initio
4079 C calculations of diethyl disulfide.
4080 C
4081 C A. Liwo and U. Kozlowska, 11/24/03
4082 C
4083       implicit real*8 (a-h,o-z)
4084       include 'DIMENSIONS'
4085       include 'COMMON.SBRIDGE'
4086       include 'COMMON.CHAIN'
4087       include 'COMMON.DERIV'
4088       include 'COMMON.LOCAL'
4089       include 'COMMON.INTERACT'
4090       include 'COMMON.VAR'
4091       include 'COMMON.IOUNITS'
4092       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4093       itypi=itype(i)
4094       xi=c(1,nres+i)
4095       yi=c(2,nres+i)
4096       zi=c(3,nres+i)
4097       dxi=dc_norm(1,nres+i)
4098       dyi=dc_norm(2,nres+i)
4099       dzi=dc_norm(3,nres+i)
4100 c      dsci_inv=dsc_inv(itypi)
4101       dsci_inv=vbld_inv(nres+i)
4102       itypj=itype(j)
4103 c      dscj_inv=dsc_inv(itypj)
4104       dscj_inv=vbld_inv(nres+j)
4105       xj=c(1,nres+j)-xi
4106       yj=c(2,nres+j)-yi
4107       zj=c(3,nres+j)-zi
4108       dxj=dc_norm(1,nres+j)
4109       dyj=dc_norm(2,nres+j)
4110       dzj=dc_norm(3,nres+j)
4111       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4112       rij=dsqrt(rrij)
4113       erij(1)=xj*rij
4114       erij(2)=yj*rij
4115       erij(3)=zj*rij
4116       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4117       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4118       om12=dxi*dxj+dyi*dyj+dzi*dzj
4119       do k=1,3
4120         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4121         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4122       enddo
4123       rij=1.0d0/rij
4124       deltad=rij-d0cm
4125       deltat1=1.0d0-om1
4126       deltat2=1.0d0+om2
4127       deltat12=om2-om1+2.0d0
4128       cosphi=om12-om1*om2
4129       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4130      &  +akct*deltad*deltat12
4131      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4132 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4133 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4134 c     &  " deltat12",deltat12," eij",eij
4135       ed=2*akcm*deltad+akct*deltat12
4136       pom1=akct*deltad
4137       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4138       eom1=-2*akth*deltat1-pom1-om2*pom2
4139       eom2= 2*akth*deltat2+pom1-om1*pom2
4140       eom12=pom2
4141       do k=1,3
4142         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4143         ghpbx(k,i)=ghpbx(k,i)-ggk
4144      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4145      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4146         ghpbx(k,j)=ghpbx(k,j)+ggk
4147      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4148      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4149         ghpbc(k,i)=ghpbc(k,i)-ggk
4150         ghpbc(k,j)=ghpbc(k,j)+ggk
4151       enddo
4152 C
4153 C Calculate the components of the gradient in DC and X
4154 C
4155 cgrad      do k=i,j-1
4156 cgrad        do l=1,3
4157 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4158 cgrad        enddo
4159 cgrad      enddo
4160       return
4161       end
4162 C--------------------------------------------------------------------------
4163       subroutine ebond(estr)
4164 c
4165 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4166 c
4167       implicit real*8 (a-h,o-z)
4168       include 'DIMENSIONS'
4169       include 'COMMON.LOCAL'
4170       include 'COMMON.GEO'
4171       include 'COMMON.INTERACT'
4172       include 'COMMON.DERIV'
4173       include 'COMMON.VAR'
4174       include 'COMMON.CHAIN'
4175       include 'COMMON.IOUNITS'
4176       include 'COMMON.NAMES'
4177       include 'COMMON.FFIELD'
4178       include 'COMMON.CONTROL'
4179       include 'COMMON.SETUP'
4180       double precision u(3),ud(3)
4181       estr=0.0d0
4182       estr1=0.0d0
4183       do i=ibondp_start,ibondp_end
4184         if (itype(i-1).eq.21 .or. itype(i).eq.21) then
4185           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4186           do j=1,3
4187           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4188      &      *dc(j,i-1)/vbld(i)
4189           enddo
4190           if (energy_dec) write(iout,*)
4191      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4192         else
4193         diff = vbld(i)-vbldp0
4194         if (energy_dec) write (iout,*)
4195      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4196         estr=estr+diff*diff
4197         do j=1,3
4198           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4199         enddo
4200 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4201         endif
4202       enddo
4203       estr=0.5d0*AKP*estr+estr1
4204 c
4205 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4206 c
4207       do i=ibond_start,ibond_end
4208         iti=itype(i)
4209         if (iti.ne.10 .and. iti.ne.21) then
4210           nbi=nbondterm(iti)
4211           if (nbi.eq.1) then
4212             diff=vbld(i+nres)-vbldsc0(1,iti)
4213             if (energy_dec) write (iout,*)
4214      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4215      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4216             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4217             do j=1,3
4218               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4219             enddo
4220           else
4221             do j=1,nbi
4222               diff=vbld(i+nres)-vbldsc0(j,iti)
4223               ud(j)=aksc(j,iti)*diff
4224               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4225             enddo
4226             uprod=u(1)
4227             do j=2,nbi
4228               uprod=uprod*u(j)
4229             enddo
4230             usum=0.0d0
4231             usumsqder=0.0d0
4232             do j=1,nbi
4233               uprod1=1.0d0
4234               uprod2=1.0d0
4235               do k=1,nbi
4236                 if (k.ne.j) then
4237                   uprod1=uprod1*u(k)
4238                   uprod2=uprod2*u(k)*u(k)
4239                 endif
4240               enddo
4241               usum=usum+uprod1
4242               usumsqder=usumsqder+ud(j)*uprod2
4243             enddo
4244             estr=estr+uprod/usum
4245             do j=1,3
4246              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4247             enddo
4248           endif
4249         endif
4250       enddo
4251       return
4252       end
4253 #ifdef CRYST_THETA
4254 C--------------------------------------------------------------------------
4255       subroutine ebend(etheta)
4256 C
4257 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4258 C angles gamma and its derivatives in consecutive thetas and gammas.
4259 C
4260       implicit real*8 (a-h,o-z)
4261       include 'DIMENSIONS'
4262       include 'COMMON.LOCAL'
4263       include 'COMMON.GEO'
4264       include 'COMMON.INTERACT'
4265       include 'COMMON.DERIV'
4266       include 'COMMON.VAR'
4267       include 'COMMON.CHAIN'
4268       include 'COMMON.IOUNITS'
4269       include 'COMMON.NAMES'
4270       include 'COMMON.FFIELD'
4271       include 'COMMON.CONTROL'
4272       common /calcthet/ term1,term2,termm,diffak,ratak,
4273      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4274      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4275       double precision y(2),z(2)
4276       delta=0.02d0*pi
4277 c      time11=dexp(-2*time)
4278 c      time12=1.0d0
4279       etheta=0.0D0
4280 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4281       do i=ithet_start,ithet_end
4282         if (itype(i-1).eq.21) cycle
4283 C Zero the energy function and its derivative at 0 or pi.
4284         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4285         it=itype(i-1)
4286         if (i.gt.3 .and. itype(i-2).ne.21) then
4287 #ifdef OSF
4288           phii=phi(i)
4289           if (phii.ne.phii) phii=150.0
4290 #else
4291           phii=phi(i)
4292 #endif
4293           y(1)=dcos(phii)
4294           y(2)=dsin(phii)
4295         else
4296           y(1)=0.0D0
4297           y(2)=0.0D0
4298         endif
4299         if (i.lt.nres .and. itype(i).ne.21) then
4300 #ifdef OSF
4301           phii1=phi(i+1)
4302           if (phii1.ne.phii1) phii1=150.0
4303           phii1=pinorm(phii1)
4304           z(1)=cos(phii1)
4305 #else
4306           phii1=phi(i+1)
4307           z(1)=dcos(phii1)
4308 #endif
4309           z(2)=dsin(phii1)
4310         else
4311           z(1)=0.0D0
4312           z(2)=0.0D0
4313         endif
4314 C Calculate the "mean" value of theta from the part of the distribution
4315 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4316 C In following comments this theta will be referred to as t_c.
4317         thet_pred_mean=0.0d0
4318         do k=1,2
4319           athetk=athet(k,it)
4320           bthetk=bthet(k,it)
4321           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4322         enddo
4323         dthett=thet_pred_mean*ssd
4324         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4325 C Derivatives of the "mean" values in gamma1 and gamma2.
4326         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4327         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4328         if (theta(i).gt.pi-delta) then
4329           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4330      &         E_tc0)
4331           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4332           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4333           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4334      &        E_theta)
4335           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4336      &        E_tc)
4337         else if (theta(i).lt.delta) then
4338           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4339           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4340           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4341      &        E_theta)
4342           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4343           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4344      &        E_tc)
4345         else
4346           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4347      &        E_theta,E_tc)
4348         endif
4349         etheta=etheta+ethetai
4350         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4351      &      'ebend',i,ethetai
4352         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4353         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4354         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4355       enddo
4356 C Ufff.... We've done all this!!!
4357       return
4358       end
4359 C---------------------------------------------------------------------------
4360       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4361      &     E_tc)
4362       implicit real*8 (a-h,o-z)
4363       include 'DIMENSIONS'
4364       include 'COMMON.LOCAL'
4365       include 'COMMON.IOUNITS'
4366       common /calcthet/ term1,term2,termm,diffak,ratak,
4367      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4368      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4369 C Calculate the contributions to both Gaussian lobes.
4370 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4371 C The "polynomial part" of the "standard deviation" of this part of
4372 C the distribution.
4373         sig=polthet(3,it)
4374         do j=2,0,-1
4375           sig=sig*thet_pred_mean+polthet(j,it)
4376         enddo
4377 C Derivative of the "interior part" of the "standard deviation of the"
4378 C gamma-dependent Gaussian lobe in t_c.
4379         sigtc=3*polthet(3,it)
4380         do j=2,1,-1
4381           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4382         enddo
4383         sigtc=sig*sigtc
4384 C Set the parameters of both Gaussian lobes of the distribution.
4385 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4386         fac=sig*sig+sigc0(it)
4387         sigcsq=fac+fac
4388         sigc=1.0D0/sigcsq
4389 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4390         sigsqtc=-4.0D0*sigcsq*sigtc
4391 c       print *,i,sig,sigtc,sigsqtc
4392 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4393         sigtc=-sigtc/(fac*fac)
4394 C Following variable is sigma(t_c)**(-2)
4395         sigcsq=sigcsq*sigcsq
4396         sig0i=sig0(it)
4397         sig0inv=1.0D0/sig0i**2
4398         delthec=thetai-thet_pred_mean
4399         delthe0=thetai-theta0i
4400         term1=-0.5D0*sigcsq*delthec*delthec
4401         term2=-0.5D0*sig0inv*delthe0*delthe0
4402 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4403 C NaNs in taking the logarithm. We extract the largest exponent which is added
4404 C to the energy (this being the log of the distribution) at the end of energy
4405 C term evaluation for this virtual-bond angle.
4406         if (term1.gt.term2) then
4407           termm=term1
4408           term2=dexp(term2-termm)
4409           term1=1.0d0
4410         else
4411           termm=term2
4412           term1=dexp(term1-termm)
4413           term2=1.0d0
4414         endif
4415 C The ratio between the gamma-independent and gamma-dependent lobes of
4416 C the distribution is a Gaussian function of thet_pred_mean too.
4417         diffak=gthet(2,it)-thet_pred_mean
4418         ratak=diffak/gthet(3,it)**2
4419         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4420 C Let's differentiate it in thet_pred_mean NOW.
4421         aktc=ak*ratak
4422 C Now put together the distribution terms to make complete distribution.
4423         termexp=term1+ak*term2
4424         termpre=sigc+ak*sig0i
4425 C Contribution of the bending energy from this theta is just the -log of
4426 C the sum of the contributions from the two lobes and the pre-exponential
4427 C factor. Simple enough, isn't it?
4428         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4429 C NOW the derivatives!!!
4430 C 6/6/97 Take into account the deformation.
4431         E_theta=(delthec*sigcsq*term1
4432      &       +ak*delthe0*sig0inv*term2)/termexp
4433         E_tc=((sigtc+aktc*sig0i)/termpre
4434      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4435      &       aktc*term2)/termexp)
4436       return
4437       end
4438 c-----------------------------------------------------------------------------
4439       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4440       implicit real*8 (a-h,o-z)
4441       include 'DIMENSIONS'
4442       include 'COMMON.LOCAL'
4443       include 'COMMON.IOUNITS'
4444       common /calcthet/ term1,term2,termm,diffak,ratak,
4445      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4446      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4447       delthec=thetai-thet_pred_mean
4448       delthe0=thetai-theta0i
4449 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4450       t3 = thetai-thet_pred_mean
4451       t6 = t3**2
4452       t9 = term1
4453       t12 = t3*sigcsq
4454       t14 = t12+t6*sigsqtc
4455       t16 = 1.0d0
4456       t21 = thetai-theta0i
4457       t23 = t21**2
4458       t26 = term2
4459       t27 = t21*t26
4460       t32 = termexp
4461       t40 = t32**2
4462       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4463      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4464      & *(-t12*t9-ak*sig0inv*t27)
4465       return
4466       end
4467 #else
4468 C--------------------------------------------------------------------------
4469       subroutine ebend(etheta)
4470 C
4471 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4472 C angles gamma and its derivatives in consecutive thetas and gammas.
4473 C ab initio-derived potentials from
4474 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4475 C
4476       implicit real*8 (a-h,o-z)
4477       include 'DIMENSIONS'
4478       include 'COMMON.LOCAL'
4479       include 'COMMON.GEO'
4480       include 'COMMON.INTERACT'
4481       include 'COMMON.DERIV'
4482       include 'COMMON.VAR'
4483       include 'COMMON.CHAIN'
4484       include 'COMMON.IOUNITS'
4485       include 'COMMON.NAMES'
4486       include 'COMMON.FFIELD'
4487       include 'COMMON.CONTROL'
4488       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4489      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4490      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4491      & sinph1ph2(maxdouble,maxdouble)
4492       logical lprn /.false./, lprn1 /.false./
4493       etheta=0.0D0
4494       do i=ithet_start,ithet_end
4495         if (itype(i-1).eq.21) cycle
4496         dethetai=0.0d0
4497         dephii=0.0d0
4498         dephii1=0.0d0
4499         theti2=0.5d0*theta(i)
4500         ityp2=ithetyp(itype(i-1))
4501         do k=1,nntheterm
4502           coskt(k)=dcos(k*theti2)
4503           sinkt(k)=dsin(k*theti2)
4504         enddo
4505         if (i.gt.3) then
4506 #ifdef OSF
4507           phii=phi(i)
4508           if (phii.ne.phii) phii=150.0
4509 #else
4510           phii=phi(i)
4511 #endif
4512           ityp1=ithetyp(itype(i-2))
4513           do k=1,nsingle
4514             cosph1(k)=dcos(k*phii)
4515             sinph1(k)=dsin(k*phii)
4516           enddo
4517         else
4518           phii=0.0d0
4519           ityp1=nthetyp+1
4520           do k=1,nsingle
4521             cosph1(k)=0.0d0
4522             sinph1(k)=0.0d0
4523           enddo
4524         endif
4525         if (i.lt.nres) then
4526 #ifdef OSF
4527           phii1=phi(i+1)
4528           if (phii1.ne.phii1) phii1=150.0
4529           phii1=pinorm(phii1)
4530 #else
4531           phii1=phi(i+1)
4532 #endif
4533           ityp3=ithetyp(itype(i))
4534           do k=1,nsingle
4535             cosph2(k)=dcos(k*phii1)
4536             sinph2(k)=dsin(k*phii1)
4537           enddo
4538         else
4539           phii1=0.0d0
4540           ityp3=nthetyp+1
4541           do k=1,nsingle
4542             cosph2(k)=0.0d0
4543             sinph2(k)=0.0d0
4544           enddo
4545         endif
4546         ethetai=aa0thet(ityp1,ityp2,ityp3)
4547         do k=1,ndouble
4548           do l=1,k-1
4549             ccl=cosph1(l)*cosph2(k-l)
4550             ssl=sinph1(l)*sinph2(k-l)
4551             scl=sinph1(l)*cosph2(k-l)
4552             csl=cosph1(l)*sinph2(k-l)
4553             cosph1ph2(l,k)=ccl-ssl
4554             cosph1ph2(k,l)=ccl+ssl
4555             sinph1ph2(l,k)=scl+csl
4556             sinph1ph2(k,l)=scl-csl
4557           enddo
4558         enddo
4559         if (lprn) then
4560         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4561      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4562         write (iout,*) "coskt and sinkt"
4563         do k=1,nntheterm
4564           write (iout,*) k,coskt(k),sinkt(k)
4565         enddo
4566         endif
4567         do k=1,ntheterm
4568           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4569           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4570      &      *coskt(k)
4571           if (lprn)
4572      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4573      &     " ethetai",ethetai
4574         enddo
4575         if (lprn) then
4576         write (iout,*) "cosph and sinph"
4577         do k=1,nsingle
4578           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4579         enddo
4580         write (iout,*) "cosph1ph2 and sinph2ph2"
4581         do k=2,ndouble
4582           do l=1,k-1
4583             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4584      &         sinph1ph2(l,k),sinph1ph2(k,l)
4585           enddo
4586         enddo
4587         write(iout,*) "ethetai",ethetai
4588         endif
4589         do m=1,ntheterm2
4590           do k=1,nsingle
4591             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4592      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4593      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4594      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4595             ethetai=ethetai+sinkt(m)*aux
4596             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4597             dephii=dephii+k*sinkt(m)*(
4598      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4599      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4600             dephii1=dephii1+k*sinkt(m)*(
4601      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4602      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4603             if (lprn)
4604      &      write (iout,*) "m",m," k",k," bbthet",
4605      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4606      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4607      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4608      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4609           enddo
4610         enddo
4611         if (lprn)
4612      &  write(iout,*) "ethetai",ethetai
4613         do m=1,ntheterm3
4614           do k=2,ndouble
4615             do l=1,k-1
4616               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4617      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4618      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4619      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4620               ethetai=ethetai+sinkt(m)*aux
4621               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4622               dephii=dephii+l*sinkt(m)*(
4623      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4624      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4625      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4626      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4627               dephii1=dephii1+(k-l)*sinkt(m)*(
4628      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4629      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4630      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4631      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4632               if (lprn) then
4633               write (iout,*) "m",m," k",k," l",l," ffthet",
4634      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4635      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4636      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4637      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4638               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4639      &            cosph1ph2(k,l)*sinkt(m),
4640      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4641               endif
4642             enddo
4643           enddo
4644         enddo
4645 10      continue
4646         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4647      &   i,theta(i)*rad2deg,phii*rad2deg,
4648      &   phii1*rad2deg,ethetai
4649         etheta=etheta+ethetai
4650         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4651         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4652         gloc(nphi+i-2,icg)=wang*dethetai
4653       enddo
4654       return
4655       end
4656 #endif
4657 #ifdef CRYST_SC
4658 c-----------------------------------------------------------------------------
4659       subroutine esc(escloc)
4660 C Calculate the local energy of a side chain and its derivatives in the
4661 C corresponding virtual-bond valence angles THETA and the spherical angles
4662 C ALPHA and OMEGA.
4663       implicit real*8 (a-h,o-z)
4664       include 'DIMENSIONS'
4665       include 'COMMON.GEO'
4666       include 'COMMON.LOCAL'
4667       include 'COMMON.VAR'
4668       include 'COMMON.INTERACT'
4669       include 'COMMON.DERIV'
4670       include 'COMMON.CHAIN'
4671       include 'COMMON.IOUNITS'
4672       include 'COMMON.NAMES'
4673       include 'COMMON.FFIELD'
4674       include 'COMMON.CONTROL'
4675       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4676      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4677       common /sccalc/ time11,time12,time112,theti,it,nlobit
4678       delta=0.02d0*pi
4679       escloc=0.0D0
4680 c     write (iout,'(a)') 'ESC'
4681       do i=loc_start,loc_end
4682         it=itype(i)
4683         if (it.eq.21) cycle
4684         if (it.eq.10) goto 1
4685         nlobit=nlob(it)
4686 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4687 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4688         theti=theta(i+1)-pipol
4689         x(1)=dtan(theti)
4690         x(2)=alph(i)
4691         x(3)=omeg(i)
4692
4693         if (x(2).gt.pi-delta) then
4694           xtemp(1)=x(1)
4695           xtemp(2)=pi-delta
4696           xtemp(3)=x(3)
4697           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4698           xtemp(2)=pi
4699           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4700           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4701      &        escloci,dersc(2))
4702           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4703      &        ddersc0(1),dersc(1))
4704           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4705      &        ddersc0(3),dersc(3))
4706           xtemp(2)=pi-delta
4707           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4708           xtemp(2)=pi
4709           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4710           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4711      &            dersc0(2),esclocbi,dersc02)
4712           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4713      &            dersc12,dersc01)
4714           call splinthet(x(2),0.5d0*delta,ss,ssd)
4715           dersc0(1)=dersc01
4716           dersc0(2)=dersc02
4717           dersc0(3)=0.0d0
4718           do k=1,3
4719             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4720           enddo
4721           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4722 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4723 c    &             esclocbi,ss,ssd
4724           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4725 c         escloci=esclocbi
4726 c         write (iout,*) escloci
4727         else if (x(2).lt.delta) then
4728           xtemp(1)=x(1)
4729           xtemp(2)=delta
4730           xtemp(3)=x(3)
4731           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4732           xtemp(2)=0.0d0
4733           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4734           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4735      &        escloci,dersc(2))
4736           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4737      &        ddersc0(1),dersc(1))
4738           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4739      &        ddersc0(3),dersc(3))
4740           xtemp(2)=delta
4741           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4742           xtemp(2)=0.0d0
4743           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4744           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4745      &            dersc0(2),esclocbi,dersc02)
4746           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4747      &            dersc12,dersc01)
4748           dersc0(1)=dersc01
4749           dersc0(2)=dersc02
4750           dersc0(3)=0.0d0
4751           call splinthet(x(2),0.5d0*delta,ss,ssd)
4752           do k=1,3
4753             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4754           enddo
4755           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4756 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4757 c    &             esclocbi,ss,ssd
4758           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4759 c         write (iout,*) escloci
4760         else
4761           call enesc(x,escloci,dersc,ddummy,.false.)
4762         endif
4763
4764         escloc=escloc+escloci
4765         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4766      &     'escloc',i,escloci
4767 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4768
4769         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4770      &   wscloc*dersc(1)
4771         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4772         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4773     1   continue
4774       enddo
4775       return
4776       end
4777 C---------------------------------------------------------------------------
4778       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4779       implicit real*8 (a-h,o-z)
4780       include 'DIMENSIONS'
4781       include 'COMMON.GEO'
4782       include 'COMMON.LOCAL'
4783       include 'COMMON.IOUNITS'
4784       common /sccalc/ time11,time12,time112,theti,it,nlobit
4785       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4786       double precision contr(maxlob,-1:1)
4787       logical mixed
4788 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4789         escloc_i=0.0D0
4790         do j=1,3
4791           dersc(j)=0.0D0
4792           if (mixed) ddersc(j)=0.0d0
4793         enddo
4794         x3=x(3)
4795
4796 C Because of periodicity of the dependence of the SC energy in omega we have
4797 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4798 C To avoid underflows, first compute & store the exponents.
4799
4800         do iii=-1,1
4801
4802           x(3)=x3+iii*dwapi
4803
4804           do j=1,nlobit
4805             do k=1,3
4806               z(k)=x(k)-censc(k,j,it)
4807             enddo
4808             do k=1,3
4809               Axk=0.0D0
4810               do l=1,3
4811                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4812               enddo
4813               Ax(k,j,iii)=Axk
4814             enddo
4815             expfac=0.0D0
4816             do k=1,3
4817               expfac=expfac+Ax(k,j,iii)*z(k)
4818             enddo
4819             contr(j,iii)=expfac
4820           enddo ! j
4821
4822         enddo ! iii
4823
4824         x(3)=x3
4825 C As in the case of ebend, we want to avoid underflows in exponentiation and
4826 C subsequent NaNs and INFs in energy calculation.
4827 C Find the largest exponent
4828         emin=contr(1,-1)
4829         do iii=-1,1
4830           do j=1,nlobit
4831             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4832           enddo
4833         enddo
4834         emin=0.5D0*emin
4835 cd      print *,'it=',it,' emin=',emin
4836
4837 C Compute the contribution to SC energy and derivatives
4838         do iii=-1,1
4839
4840           do j=1,nlobit
4841 #ifdef OSF
4842             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4843             if(adexp.ne.adexp) adexp=1.0
4844             expfac=dexp(adexp)
4845 #else
4846             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4847 #endif
4848 cd          print *,'j=',j,' expfac=',expfac
4849             escloc_i=escloc_i+expfac
4850             do k=1,3
4851               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4852             enddo
4853             if (mixed) then
4854               do k=1,3,2
4855                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4856      &            +gaussc(k,2,j,it))*expfac
4857               enddo
4858             endif
4859           enddo
4860
4861         enddo ! iii
4862
4863         dersc(1)=dersc(1)/cos(theti)**2
4864         ddersc(1)=ddersc(1)/cos(theti)**2
4865         ddersc(3)=ddersc(3)
4866
4867         escloci=-(dlog(escloc_i)-emin)
4868         do j=1,3
4869           dersc(j)=dersc(j)/escloc_i
4870         enddo
4871         if (mixed) then
4872           do j=1,3,2
4873             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4874           enddo
4875         endif
4876       return
4877       end
4878 C------------------------------------------------------------------------------
4879       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4880       implicit real*8 (a-h,o-z)
4881       include 'DIMENSIONS'
4882       include 'COMMON.GEO'
4883       include 'COMMON.LOCAL'
4884       include 'COMMON.IOUNITS'
4885       common /sccalc/ time11,time12,time112,theti,it,nlobit
4886       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4887       double precision contr(maxlob)
4888       logical mixed
4889
4890       escloc_i=0.0D0
4891
4892       do j=1,3
4893         dersc(j)=0.0D0
4894       enddo
4895
4896       do j=1,nlobit
4897         do k=1,2
4898           z(k)=x(k)-censc(k,j,it)
4899         enddo
4900         z(3)=dwapi
4901         do k=1,3
4902           Axk=0.0D0
4903           do l=1,3
4904             Axk=Axk+gaussc(l,k,j,it)*z(l)
4905           enddo
4906           Ax(k,j)=Axk
4907         enddo
4908         expfac=0.0D0
4909         do k=1,3
4910           expfac=expfac+Ax(k,j)*z(k)
4911         enddo
4912         contr(j)=expfac
4913       enddo ! j
4914
4915 C As in the case of ebend, we want to avoid underflows in exponentiation and
4916 C subsequent NaNs and INFs in energy calculation.
4917 C Find the largest exponent
4918       emin=contr(1)
4919       do j=1,nlobit
4920         if (emin.gt.contr(j)) emin=contr(j)
4921       enddo
4922       emin=0.5D0*emin
4923
4924 C Compute the contribution to SC energy and derivatives
4925
4926       dersc12=0.0d0
4927       do j=1,nlobit
4928         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4929         escloc_i=escloc_i+expfac
4930         do k=1,2
4931           dersc(k)=dersc(k)+Ax(k,j)*expfac
4932         enddo
4933         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4934      &            +gaussc(1,2,j,it))*expfac
4935         dersc(3)=0.0d0
4936       enddo
4937
4938       dersc(1)=dersc(1)/cos(theti)**2
4939       dersc12=dersc12/cos(theti)**2
4940       escloci=-(dlog(escloc_i)-emin)
4941       do j=1,2
4942         dersc(j)=dersc(j)/escloc_i
4943       enddo
4944       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4945       return
4946       end
4947 #else
4948 c----------------------------------------------------------------------------------
4949       subroutine esc(escloc)
4950 C Calculate the local energy of a side chain and its derivatives in the
4951 C corresponding virtual-bond valence angles THETA and the spherical angles
4952 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4953 C added by Urszula Kozlowska. 07/11/2007
4954 C
4955       implicit real*8 (a-h,o-z)
4956       include 'DIMENSIONS'
4957       include 'COMMON.GEO'
4958       include 'COMMON.LOCAL'
4959       include 'COMMON.VAR'
4960       include 'COMMON.SCROT'
4961       include 'COMMON.INTERACT'
4962       include 'COMMON.DERIV'
4963       include 'COMMON.CHAIN'
4964       include 'COMMON.IOUNITS'
4965       include 'COMMON.NAMES'
4966       include 'COMMON.FFIELD'
4967       include 'COMMON.CONTROL'
4968       include 'COMMON.VECTORS'
4969       double precision x_prime(3),y_prime(3),z_prime(3)
4970      &    , sumene,dsc_i,dp2_i,x(65),
4971      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4972      &    de_dxx,de_dyy,de_dzz,de_dt
4973       double precision s1_t,s1_6_t,s2_t,s2_6_t
4974       double precision
4975      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4976      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4977      & dt_dCi(3),dt_dCi1(3)
4978       common /sccalc/ time11,time12,time112,theti,it,nlobit
4979       delta=0.02d0*pi
4980       escloc=0.0D0
4981       do i=loc_start,loc_end
4982         if (itype(i).eq.21) cycle
4983         costtab(i+1) =dcos(theta(i+1))
4984         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4985         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4986         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4987         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4988         cosfac=dsqrt(cosfac2)
4989         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4990         sinfac=dsqrt(sinfac2)
4991         it=itype(i)
4992         if (it.eq.10) goto 1
4993 c
4994 C  Compute the axes of tghe local cartesian coordinates system; store in
4995 c   x_prime, y_prime and z_prime
4996 c
4997         do j=1,3
4998           x_prime(j) = 0.00
4999           y_prime(j) = 0.00
5000           z_prime(j) = 0.00
5001         enddo
5002 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5003 C     &   dc_norm(3,i+nres)
5004         do j = 1,3
5005           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5006           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5007         enddo
5008         do j = 1,3
5009           z_prime(j) = -uz(j,i-1)
5010         enddo
5011 c       write (2,*) "i",i
5012 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5013 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5014 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5015 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5016 c      & " xy",scalar(x_prime(1),y_prime(1)),
5017 c      & " xz",scalar(x_prime(1),z_prime(1)),
5018 c      & " yy",scalar(y_prime(1),y_prime(1)),
5019 c      & " yz",scalar(y_prime(1),z_prime(1)),
5020 c      & " zz",scalar(z_prime(1),z_prime(1))
5021 c
5022 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5023 C to local coordinate system. Store in xx, yy, zz.
5024 c
5025         xx=0.0d0
5026         yy=0.0d0
5027         zz=0.0d0
5028         do j = 1,3
5029           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5030           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5031           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5032         enddo
5033
5034         xxtab(i)=xx
5035         yytab(i)=yy
5036         zztab(i)=zz
5037 C
5038 C Compute the energy of the ith side cbain
5039 C
5040 c        write (2,*) "xx",xx," yy",yy," zz",zz
5041         it=itype(i)
5042         do j = 1,65
5043           x(j) = sc_parmin(j,it)
5044         enddo
5045 #ifdef CHECK_COORD
5046 Cc diagnostics - remove later
5047         xx1 = dcos(alph(2))
5048         yy1 = dsin(alph(2))*dcos(omeg(2))
5049         zz1 = -dsin(alph(2))*dsin(omeg(2))
5050         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5051      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5052      &    xx1,yy1,zz1
5053 C,"  --- ", xx_w,yy_w,zz_w
5054 c end diagnostics
5055 #endif
5056         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5057      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5058      &   + x(10)*yy*zz
5059         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5060      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5061      & + x(20)*yy*zz
5062         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5063      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5064      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5065      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5066      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5067      &  +x(40)*xx*yy*zz
5068         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5069      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5070      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5071      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5072      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5073      &  +x(60)*xx*yy*zz
5074         dsc_i   = 0.743d0+x(61)
5075         dp2_i   = 1.9d0+x(62)
5076         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5077      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5078         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5079      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5080         s1=(1+x(63))/(0.1d0 + dscp1)
5081         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5082         s2=(1+x(65))/(0.1d0 + dscp2)
5083         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5084         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5085      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5086 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5087 c     &   sumene4,
5088 c     &   dscp1,dscp2,sumene
5089 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5090         escloc = escloc + sumene
5091 c        write (2,*) "i",i," escloc",sumene,escloc
5092 #ifdef DEBUG
5093 C
5094 C This section to check the numerical derivatives of the energy of ith side
5095 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5096 C #define DEBUG in the code to turn it on.
5097 C
5098         write (2,*) "sumene               =",sumene
5099         aincr=1.0d-7
5100         xxsave=xx
5101         xx=xx+aincr
5102         write (2,*) xx,yy,zz
5103         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5104         de_dxx_num=(sumenep-sumene)/aincr
5105         xx=xxsave
5106         write (2,*) "xx+ sumene from enesc=",sumenep
5107         yysave=yy
5108         yy=yy+aincr
5109         write (2,*) xx,yy,zz
5110         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5111         de_dyy_num=(sumenep-sumene)/aincr
5112         yy=yysave
5113         write (2,*) "yy+ sumene from enesc=",sumenep
5114         zzsave=zz
5115         zz=zz+aincr
5116         write (2,*) xx,yy,zz
5117         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5118         de_dzz_num=(sumenep-sumene)/aincr
5119         zz=zzsave
5120         write (2,*) "zz+ sumene from enesc=",sumenep
5121         costsave=cost2tab(i+1)
5122         sintsave=sint2tab(i+1)
5123         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5124         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5125         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5126         de_dt_num=(sumenep-sumene)/aincr
5127         write (2,*) " t+ sumene from enesc=",sumenep
5128         cost2tab(i+1)=costsave
5129         sint2tab(i+1)=sintsave
5130 C End of diagnostics section.
5131 #endif
5132 C
5133 C Compute the gradient of esc
5134 C
5135         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5136         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5137         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5138         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5139         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5140         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5141         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5142         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5143         pom1=(sumene3*sint2tab(i+1)+sumene1)
5144      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5145         pom2=(sumene4*cost2tab(i+1)+sumene2)
5146      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5147         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5148         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5149      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5150      &  +x(40)*yy*zz
5151         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5152         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5153      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5154      &  +x(60)*yy*zz
5155         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5156      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5157      &        +(pom1+pom2)*pom_dx
5158 #ifdef DEBUG
5159         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5160 #endif
5161 C
5162         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5163         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5164      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5165      &  +x(40)*xx*zz
5166         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5167         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5168      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5169      &  +x(59)*zz**2 +x(60)*xx*zz
5170         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5171      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5172      &        +(pom1-pom2)*pom_dy
5173 #ifdef DEBUG
5174         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5175 #endif
5176 C
5177         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5178      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5179      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5180      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5181      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5182      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5183      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5184      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5185 #ifdef DEBUG
5186         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5187 #endif
5188 C
5189         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5190      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5191      &  +pom1*pom_dt1+pom2*pom_dt2
5192 #ifdef DEBUG
5193         write(2,*), "de_dt = ", de_dt,de_dt_num
5194 #endif
5195 c
5196 C
5197        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5198        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5199        cosfac2xx=cosfac2*xx
5200        sinfac2yy=sinfac2*yy
5201        do k = 1,3
5202          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5203      &      vbld_inv(i+1)
5204          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5205      &      vbld_inv(i)
5206          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5207          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5208 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5209 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5210 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5211 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5212          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5213          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5214          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5215          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5216          dZZ_Ci1(k)=0.0d0
5217          dZZ_Ci(k)=0.0d0
5218          do j=1,3
5219            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5220            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5221          enddo
5222
5223          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5224          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5225          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5226 c
5227          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5228          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5229        enddo
5230
5231        do k=1,3
5232          dXX_Ctab(k,i)=dXX_Ci(k)
5233          dXX_C1tab(k,i)=dXX_Ci1(k)
5234          dYY_Ctab(k,i)=dYY_Ci(k)
5235          dYY_C1tab(k,i)=dYY_Ci1(k)
5236          dZZ_Ctab(k,i)=dZZ_Ci(k)
5237          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5238          dXX_XYZtab(k,i)=dXX_XYZ(k)
5239          dYY_XYZtab(k,i)=dYY_XYZ(k)
5240          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5241        enddo
5242
5243        do k = 1,3
5244 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5245 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5246 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5247 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5248 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5249 c     &    dt_dci(k)
5250 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5251 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5252          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5253      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5254          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5255      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5256          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5257      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5258        enddo
5259 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5260 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5261
5262 C to check gradient call subroutine check_grad
5263
5264     1 continue
5265       enddo
5266       return
5267       end
5268 c------------------------------------------------------------------------------
5269       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5270       implicit none
5271       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5272      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5273       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5274      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5275      &   + x(10)*yy*zz
5276       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5277      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5278      & + x(20)*yy*zz
5279       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5280      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5281      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5282      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5283      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5284      &  +x(40)*xx*yy*zz
5285       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5286      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5287      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5288      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5289      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5290      &  +x(60)*xx*yy*zz
5291       dsc_i   = 0.743d0+x(61)
5292       dp2_i   = 1.9d0+x(62)
5293       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5294      &          *(xx*cost2+yy*sint2))
5295       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5296      &          *(xx*cost2-yy*sint2))
5297       s1=(1+x(63))/(0.1d0 + dscp1)
5298       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5299       s2=(1+x(65))/(0.1d0 + dscp2)
5300       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5301       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5302      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5303       enesc=sumene
5304       return
5305       end
5306 #endif
5307 c------------------------------------------------------------------------------
5308       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5309 C
5310 C This procedure calculates two-body contact function g(rij) and its derivative:
5311 C
5312 C           eps0ij                                     !       x < -1
5313 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5314 C            0                                         !       x > 1
5315 C
5316 C where x=(rij-r0ij)/delta
5317 C
5318 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5319 C
5320       implicit none
5321       double precision rij,r0ij,eps0ij,fcont,fprimcont
5322       double precision x,x2,x4,delta
5323 c     delta=0.02D0*r0ij
5324 c      delta=0.2D0*r0ij
5325       x=(rij-r0ij)/delta
5326       if (x.lt.-1.0D0) then
5327         fcont=eps0ij
5328         fprimcont=0.0D0
5329       else if (x.le.1.0D0) then
5330         x2=x*x
5331         x4=x2*x2
5332         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5333         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5334       else
5335         fcont=0.0D0
5336         fprimcont=0.0D0
5337       endif
5338       return
5339       end
5340 c------------------------------------------------------------------------------
5341       subroutine splinthet(theti,delta,ss,ssder)
5342       implicit real*8 (a-h,o-z)
5343       include 'DIMENSIONS'
5344       include 'COMMON.VAR'
5345       include 'COMMON.GEO'
5346       thetup=pi-delta
5347       thetlow=delta
5348       if (theti.gt.pipol) then
5349         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5350       else
5351         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5352         ssder=-ssder
5353       endif
5354       return
5355       end
5356 c------------------------------------------------------------------------------
5357       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5358       implicit none
5359       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5360       double precision ksi,ksi2,ksi3,a1,a2,a3
5361       a1=fprim0*delta/(f1-f0)
5362       a2=3.0d0-2.0d0*a1
5363       a3=a1-2.0d0
5364       ksi=(x-x0)/delta
5365       ksi2=ksi*ksi
5366       ksi3=ksi2*ksi
5367       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5368       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5369       return
5370       end
5371 c------------------------------------------------------------------------------
5372       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5373       implicit none
5374       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5375       double precision ksi,ksi2,ksi3,a1,a2,a3
5376       ksi=(x-x0)/delta
5377       ksi2=ksi*ksi
5378       ksi3=ksi2*ksi
5379       a1=fprim0x*delta
5380       a2=3*(f1x-f0x)-2*fprim0x*delta
5381       a3=fprim0x*delta-2*(f1x-f0x)
5382       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5383       return
5384       end
5385 C-----------------------------------------------------------------------------
5386 #ifdef CRYST_TOR
5387 C-----------------------------------------------------------------------------
5388       subroutine etor(etors,edihcnstr)
5389       implicit real*8 (a-h,o-z)
5390       include 'DIMENSIONS'
5391       include 'COMMON.VAR'
5392       include 'COMMON.GEO'
5393       include 'COMMON.LOCAL'
5394       include 'COMMON.TORSION'
5395       include 'COMMON.INTERACT'
5396       include 'COMMON.DERIV'
5397       include 'COMMON.CHAIN'
5398       include 'COMMON.NAMES'
5399       include 'COMMON.IOUNITS'
5400       include 'COMMON.FFIELD'
5401       include 'COMMON.TORCNSTR'
5402       include 'COMMON.CONTROL'
5403       logical lprn
5404 C Set lprn=.true. for debugging
5405       lprn=.false.
5406 c      lprn=.true.
5407       etors=0.0D0
5408       do i=iphi_start,iphi_end
5409       etors_ii=0.0D0
5410         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5411      &      .or. itype(i).eq.21) cycle
5412         itori=itortyp(itype(i-2))
5413         itori1=itortyp(itype(i-1))
5414         phii=phi(i)
5415         gloci=0.0D0
5416 C Proline-Proline pair is a special case...
5417         if (itori.eq.3 .and. itori1.eq.3) then
5418           if (phii.gt.-dwapi3) then
5419             cosphi=dcos(3*phii)
5420             fac=1.0D0/(1.0D0-cosphi)
5421             etorsi=v1(1,3,3)*fac
5422             etorsi=etorsi+etorsi
5423             etors=etors+etorsi-v1(1,3,3)
5424             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5425             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5426           endif
5427           do j=1,3
5428             v1ij=v1(j+1,itori,itori1)
5429             v2ij=v2(j+1,itori,itori1)
5430             cosphi=dcos(j*phii)
5431             sinphi=dsin(j*phii)
5432             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5433             if (energy_dec) etors_ii=etors_ii+
5434      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5435             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5436           enddo
5437         else
5438           do j=1,nterm_old
5439             v1ij=v1(j,itori,itori1)
5440             v2ij=v2(j,itori,itori1)
5441             cosphi=dcos(j*phii)
5442             sinphi=dsin(j*phii)
5443             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5444             if (energy_dec) etors_ii=etors_ii+
5445      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5446             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5447           enddo
5448         endif
5449         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5450              'etor',i,etors_ii
5451         if (lprn)
5452      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5453      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5454      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5455         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5456 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5457       enddo
5458 ! 6/20/98 - dihedral angle constraints
5459       edihcnstr=0.0d0
5460       do i=1,ndih_constr
5461         itori=idih_constr(i)
5462         phii=phi(itori)
5463         difi=phii-phi0(i)
5464         if (difi.gt.drange(i)) then
5465           difi=difi-drange(i)
5466           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5467           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5468         else if (difi.lt.-drange(i)) then
5469           difi=difi+drange(i)
5470           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5471           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5472         endif
5473 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5474 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5475       enddo
5476 !      write (iout,*) 'edihcnstr',edihcnstr
5477       return
5478       end
5479 c------------------------------------------------------------------------------
5480       subroutine etor_d(etors_d)
5481       etors_d=0.0d0
5482       return
5483       end
5484 c----------------------------------------------------------------------------
5485 #else
5486       subroutine etor(etors,edihcnstr)
5487       implicit real*8 (a-h,o-z)
5488       include 'DIMENSIONS'
5489       include 'COMMON.VAR'
5490       include 'COMMON.GEO'
5491       include 'COMMON.LOCAL'
5492       include 'COMMON.TORSION'
5493       include 'COMMON.INTERACT'
5494       include 'COMMON.DERIV'
5495       include 'COMMON.CHAIN'
5496       include 'COMMON.NAMES'
5497       include 'COMMON.IOUNITS'
5498       include 'COMMON.FFIELD'
5499       include 'COMMON.TORCNSTR'
5500       include 'COMMON.CONTROL'
5501       logical lprn
5502 C Set lprn=.true. for debugging
5503       lprn=.false.
5504 c     lprn=.true.
5505       etors=0.0D0
5506       do i=iphi_start,iphi_end
5507         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5508      &       .or. itype(i).eq.21) cycle
5509         etors_ii=0.0D0
5510         itori=itortyp(itype(i-2))
5511         itori1=itortyp(itype(i-1))
5512         phii=phi(i)
5513         gloci=0.0D0
5514 C Regular cosine and sine terms
5515         do j=1,nterm(itori,itori1)
5516           v1ij=v1(j,itori,itori1)
5517           v2ij=v2(j,itori,itori1)
5518           cosphi=dcos(j*phii)
5519           sinphi=dsin(j*phii)
5520           etors=etors+v1ij*cosphi+v2ij*sinphi
5521           if (energy_dec) etors_ii=etors_ii+
5522      &                v1ij*cosphi+v2ij*sinphi
5523           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5524         enddo
5525 C Lorentz terms
5526 C                         v1
5527 C  E = SUM ----------------------------------- - v1
5528 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5529 C
5530         cosphi=dcos(0.5d0*phii)
5531         sinphi=dsin(0.5d0*phii)
5532         do j=1,nlor(itori,itori1)
5533           vl1ij=vlor1(j,itori,itori1)
5534           vl2ij=vlor2(j,itori,itori1)
5535           vl3ij=vlor3(j,itori,itori1)
5536           pom=vl2ij*cosphi+vl3ij*sinphi
5537           pom1=1.0d0/(pom*pom+1.0d0)
5538           etors=etors+vl1ij*pom1
5539           if (energy_dec) etors_ii=etors_ii+
5540      &                vl1ij*pom1
5541           pom=-pom*pom1*pom1
5542           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5543         enddo
5544 C Subtract the constant term
5545         etors=etors-v0(itori,itori1)
5546           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5547      &         'etor',i,etors_ii-v0(itori,itori1)
5548         if (lprn)
5549      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5550      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5551      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5552         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5553 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5554       enddo
5555 ! 6/20/98 - dihedral angle constraints
5556       edihcnstr=0.0d0
5557 c      do i=1,ndih_constr
5558       do i=idihconstr_start,idihconstr_end
5559         itori=idih_constr(i)
5560         phii=phi(itori)
5561         difi=pinorm(phii-phi0(i))
5562         if (difi.gt.drange(i)) then
5563           difi=difi-drange(i)
5564           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5565           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5566         else if (difi.lt.-drange(i)) then
5567           difi=difi+drange(i)
5568           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5569           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5570         else
5571           difi=0.0
5572         endif
5573 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5574 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5575 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5576       enddo
5577 cd       write (iout,*) 'edihcnstr',edihcnstr
5578       return
5579       end
5580 c----------------------------------------------------------------------------
5581       subroutine etor_d(etors_d)
5582 C 6/23/01 Compute double torsional energy
5583       implicit real*8 (a-h,o-z)
5584       include 'DIMENSIONS'
5585       include 'COMMON.VAR'
5586       include 'COMMON.GEO'
5587       include 'COMMON.LOCAL'
5588       include 'COMMON.TORSION'
5589       include 'COMMON.INTERACT'
5590       include 'COMMON.DERIV'
5591       include 'COMMON.CHAIN'
5592       include 'COMMON.NAMES'
5593       include 'COMMON.IOUNITS'
5594       include 'COMMON.FFIELD'
5595       include 'COMMON.TORCNSTR'
5596       logical lprn
5597 C Set lprn=.true. for debugging
5598       lprn=.false.
5599 c     lprn=.true.
5600       etors_d=0.0D0
5601       do i=iphid_start,iphid_end
5602         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5603      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle
5604         itori=itortyp(itype(i-2))
5605         itori1=itortyp(itype(i-1))
5606         itori2=itortyp(itype(i))
5607         phii=phi(i)
5608         phii1=phi(i+1)
5609         gloci1=0.0D0
5610         gloci2=0.0D0
5611 C Regular cosine and sine terms
5612         do j=1,ntermd_1(itori,itori1,itori2)
5613           v1cij=v1c(1,j,itori,itori1,itori2)
5614           v1sij=v1s(1,j,itori,itori1,itori2)
5615           v2cij=v1c(2,j,itori,itori1,itori2)
5616           v2sij=v1s(2,j,itori,itori1,itori2)
5617           cosphi1=dcos(j*phii)
5618           sinphi1=dsin(j*phii)
5619           cosphi2=dcos(j*phii1)
5620           sinphi2=dsin(j*phii1)
5621           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5622      &     v2cij*cosphi2+v2sij*sinphi2
5623           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5624           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5625         enddo
5626         do k=2,ntermd_2(itori,itori1,itori2)
5627           do l=1,k-1
5628             v1cdij = v2c(k,l,itori,itori1,itori2)
5629             v2cdij = v2c(l,k,itori,itori1,itori2)
5630             v1sdij = v2s(k,l,itori,itori1,itori2)
5631             v2sdij = v2s(l,k,itori,itori1,itori2)
5632             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5633             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5634             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5635             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5636             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5637      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5638             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5639      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5640             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5641      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5642           enddo
5643         enddo
5644         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5645         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5646       enddo
5647       return
5648       end
5649 #endif
5650 c------------------------------------------------------------------------------
5651       subroutine eback_sc_corr(esccor)
5652 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5653 c        conformational states; temporarily implemented as differences
5654 c        between UNRES torsional potentials (dependent on three types of
5655 c        residues) and the torsional potentials dependent on all 20 types
5656 c        of residues computed from AM1  energy surfaces of terminally-blocked
5657 c        amino-acid residues.
5658       implicit real*8 (a-h,o-z)
5659       include 'DIMENSIONS'
5660       include 'COMMON.VAR'
5661       include 'COMMON.GEO'
5662       include 'COMMON.LOCAL'
5663       include 'COMMON.TORSION'
5664       include 'COMMON.SCCOR'
5665       include 'COMMON.INTERACT'
5666       include 'COMMON.DERIV'
5667       include 'COMMON.CHAIN'
5668       include 'COMMON.NAMES'
5669       include 'COMMON.IOUNITS'
5670       include 'COMMON.FFIELD'
5671       include 'COMMON.CONTROL'
5672       logical lprn
5673 C Set lprn=.true. for debugging
5674       lprn=.false.
5675 c      lprn=.true.
5676 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5677       esccor=0.0D0
5678       do i=iphi_start,iphi_end
5679         if (itype(i-2).eq.21 .or. itype(i-1).eq.21) cycle
5680         esccor_ii=0.0D0
5681         itori=itype(i-2)
5682         itori1=itype(i-1)
5683         phii=phi(i)
5684         gloci=0.0D0
5685         do j=1,nterm_sccor
5686           v1ij=v1sccor(j,itori,itori1)
5687           v2ij=v2sccor(j,itori,itori1)
5688           cosphi=dcos(j*phii)
5689           sinphi=dsin(j*phii)
5690           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5691           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5692         enddo
5693         if (lprn)
5694      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5695      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5696      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5697         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5698       enddo
5699       return
5700       end
5701 c----------------------------------------------------------------------------
5702       subroutine multibody(ecorr)
5703 C This subroutine calculates multi-body contributions to energy following
5704 C the idea of Skolnick et al. If side chains I and J make a contact and
5705 C at the same time side chains I+1 and J+1 make a contact, an extra
5706 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5707       implicit real*8 (a-h,o-z)
5708       include 'DIMENSIONS'
5709       include 'COMMON.IOUNITS'
5710       include 'COMMON.DERIV'
5711       include 'COMMON.INTERACT'
5712       include 'COMMON.CONTACTS'
5713       double precision gx(3),gx1(3)
5714       logical lprn
5715
5716 C Set lprn=.true. for debugging
5717       lprn=.false.
5718
5719       if (lprn) then
5720         write (iout,'(a)') 'Contact function values:'
5721         do i=nnt,nct-2
5722           write (iout,'(i2,20(1x,i2,f10.5))')
5723      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5724         enddo
5725       endif
5726       ecorr=0.0D0
5727       do i=nnt,nct
5728         do j=1,3
5729           gradcorr(j,i)=0.0D0
5730           gradxorr(j,i)=0.0D0
5731         enddo
5732       enddo
5733       do i=nnt,nct-2
5734
5735         DO ISHIFT = 3,4
5736
5737         i1=i+ishift
5738         num_conti=num_cont(i)
5739         num_conti1=num_cont(i1)
5740         do jj=1,num_conti
5741           j=jcont(jj,i)
5742           do kk=1,num_conti1
5743             j1=jcont(kk,i1)
5744             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5745 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5746 cd   &                   ' ishift=',ishift
5747 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5748 C The system gains extra energy.
5749               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5750             endif   ! j1==j+-ishift
5751           enddo     ! kk
5752         enddo       ! jj
5753
5754         ENDDO ! ISHIFT
5755
5756       enddo         ! i
5757       return
5758       end
5759 c------------------------------------------------------------------------------
5760       double precision function esccorr(i,j,k,l,jj,kk)
5761       implicit real*8 (a-h,o-z)
5762       include 'DIMENSIONS'
5763       include 'COMMON.IOUNITS'
5764       include 'COMMON.DERIV'
5765       include 'COMMON.INTERACT'
5766       include 'COMMON.CONTACTS'
5767       double precision gx(3),gx1(3)
5768       logical lprn
5769       lprn=.false.
5770       eij=facont(jj,i)
5771       ekl=facont(kk,k)
5772 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5773 C Calculate the multi-body contribution to energy.
5774 C Calculate multi-body contributions to the gradient.
5775 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5776 cd   & k,l,(gacont(m,kk,k),m=1,3)
5777       do m=1,3
5778         gx(m) =ekl*gacont(m,jj,i)
5779         gx1(m)=eij*gacont(m,kk,k)
5780         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5781         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5782         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5783         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5784       enddo
5785       do m=i,j-1
5786         do ll=1,3
5787           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5788         enddo
5789       enddo
5790       do m=k,l-1
5791         do ll=1,3
5792           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5793         enddo
5794       enddo
5795       esccorr=-eij*ekl
5796       return
5797       end
5798 c------------------------------------------------------------------------------
5799       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5800 C This subroutine calculates multi-body contributions to hydrogen-bonding
5801       implicit real*8 (a-h,o-z)
5802       include 'DIMENSIONS'
5803       include 'COMMON.IOUNITS'
5804 #ifdef MPI
5805       include "mpif.h"
5806       parameter (max_cont=maxconts)
5807       parameter (max_dim=26)
5808       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5809       double precision zapas(max_dim,maxconts,max_fg_procs),
5810      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5811       common /przechowalnia/ zapas
5812       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5813      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5814 #endif
5815       include 'COMMON.SETUP'
5816       include 'COMMON.FFIELD'
5817       include 'COMMON.DERIV'
5818       include 'COMMON.INTERACT'
5819       include 'COMMON.CONTACTS'
5820       include 'COMMON.CONTROL'
5821       include 'COMMON.LOCAL'
5822       double precision gx(3),gx1(3),time00
5823       logical lprn,ldone
5824
5825 C Set lprn=.true. for debugging
5826       lprn=.false.
5827 #ifdef MPI
5828       n_corr=0
5829       n_corr1=0
5830       if (nfgtasks.le.1) goto 30
5831       if (lprn) then
5832         write (iout,'(a)') 'Contact function values before RECEIVE:'
5833         do i=nnt,nct-2
5834           write (iout,'(2i3,50(1x,i2,f5.2))')
5835      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5836      &    j=1,num_cont_hb(i))
5837         enddo
5838       endif
5839       call flush(iout)
5840       do i=1,ntask_cont_from
5841         ncont_recv(i)=0
5842       enddo
5843       do i=1,ntask_cont_to
5844         ncont_sent(i)=0
5845       enddo
5846 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5847 c     & ntask_cont_to
5848 C Make the list of contacts to send to send to other procesors
5849 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5850 c      call flush(iout)
5851       do i=iturn3_start,iturn3_end
5852 c        write (iout,*) "make contact list turn3",i," num_cont",
5853 c     &    num_cont_hb(i)
5854         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5855       enddo
5856       do i=iturn4_start,iturn4_end
5857 c        write (iout,*) "make contact list turn4",i," num_cont",
5858 c     &   num_cont_hb(i)
5859         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5860       enddo
5861       do ii=1,nat_sent
5862         i=iat_sent(ii)
5863 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5864 c     &    num_cont_hb(i)
5865         do j=1,num_cont_hb(i)
5866         do k=1,4
5867           jjc=jcont_hb(j,i)
5868           iproc=iint_sent_local(k,jjc,ii)
5869 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5870           if (iproc.gt.0) then
5871             ncont_sent(iproc)=ncont_sent(iproc)+1
5872             nn=ncont_sent(iproc)
5873             zapas(1,nn,iproc)=i
5874             zapas(2,nn,iproc)=jjc
5875             zapas(3,nn,iproc)=facont_hb(j,i)
5876             zapas(4,nn,iproc)=ees0p(j,i)
5877             zapas(5,nn,iproc)=ees0m(j,i)
5878             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5879             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5880             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5881             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5882             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5883             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5884             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5885             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5886             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5887             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5888             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5889             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5890             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5891             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5892             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5893             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5894             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5895             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5896             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5897             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5898             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5899           endif
5900         enddo
5901         enddo
5902       enddo
5903       if (lprn) then
5904       write (iout,*)
5905      &  "Numbers of contacts to be sent to other processors",
5906      &  (ncont_sent(i),i=1,ntask_cont_to)
5907       write (iout,*) "Contacts sent"
5908       do ii=1,ntask_cont_to
5909         nn=ncont_sent(ii)
5910         iproc=itask_cont_to(ii)
5911         write (iout,*) nn," contacts to processor",iproc,
5912      &   " of CONT_TO_COMM group"
5913         do i=1,nn
5914           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5915         enddo
5916       enddo
5917       call flush(iout)
5918       endif
5919       CorrelType=477
5920       CorrelID=fg_rank+1
5921       CorrelType1=478
5922       CorrelID1=nfgtasks+fg_rank+1
5923       ireq=0
5924 C Receive the numbers of needed contacts from other processors
5925       do ii=1,ntask_cont_from
5926         iproc=itask_cont_from(ii)
5927         ireq=ireq+1
5928         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
5929      &    FG_COMM,req(ireq),IERR)
5930       enddo
5931 c      write (iout,*) "IRECV ended"
5932 c      call flush(iout)
5933 C Send the number of contacts needed by other processors
5934       do ii=1,ntask_cont_to
5935         iproc=itask_cont_to(ii)
5936         ireq=ireq+1
5937         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
5938      &    FG_COMM,req(ireq),IERR)
5939       enddo
5940 c      write (iout,*) "ISEND ended"
5941 c      write (iout,*) "number of requests (nn)",ireq
5942       call flush(iout)
5943       if (ireq.gt.0)
5944      &  call MPI_Waitall(ireq,req,status_array,ierr)
5945 c      write (iout,*)
5946 c     &  "Numbers of contacts to be received from other processors",
5947 c     &  (ncont_recv(i),i=1,ntask_cont_from)
5948 c      call flush(iout)
5949 C Receive contacts
5950       ireq=0
5951       do ii=1,ntask_cont_from
5952         iproc=itask_cont_from(ii)
5953         nn=ncont_recv(ii)
5954 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
5955 c     &   " of CONT_TO_COMM group"
5956         call flush(iout)
5957         if (nn.gt.0) then
5958           ireq=ireq+1
5959           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
5960      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
5961 c          write (iout,*) "ireq,req",ireq,req(ireq)
5962         endif
5963       enddo
5964 C Send the contacts to processors that need them
5965       do ii=1,ntask_cont_to
5966         iproc=itask_cont_to(ii)
5967         nn=ncont_sent(ii)
5968 c        write (iout,*) nn," contacts to processor",iproc,
5969 c     &   " of CONT_TO_COMM group"
5970         if (nn.gt.0) then
5971           ireq=ireq+1
5972           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
5973      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
5974 c          write (iout,*) "ireq,req",ireq,req(ireq)
5975 c          do i=1,nn
5976 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5977 c          enddo
5978         endif
5979       enddo
5980 c      write (iout,*) "number of requests (contacts)",ireq
5981 c      write (iout,*) "req",(req(i),i=1,4)
5982 c      call flush(iout)
5983       if (ireq.gt.0)
5984      & call MPI_Waitall(ireq,req,status_array,ierr)
5985       do iii=1,ntask_cont_from
5986         iproc=itask_cont_from(iii)
5987         nn=ncont_recv(iii)
5988         if (lprn) then
5989         write (iout,*) "Received",nn," contacts from processor",iproc,
5990      &   " of CONT_FROM_COMM group"
5991         call flush(iout)
5992         do i=1,nn
5993           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
5994         enddo
5995         call flush(iout)
5996         endif
5997         do i=1,nn
5998           ii=zapas_recv(1,i,iii)
5999 c Flag the received contacts to prevent double-counting
6000           jj=-zapas_recv(2,i,iii)
6001 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6002 c          call flush(iout)
6003           nnn=num_cont_hb(ii)+1
6004           num_cont_hb(ii)=nnn
6005           jcont_hb(nnn,ii)=jj
6006           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6007           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6008           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6009           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6010           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6011           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6012           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6013           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6014           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6015           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6016           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6017           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6018           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6019           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6020           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6021           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6022           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6023           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6024           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6025           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6026           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6027           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6028           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6029           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6030         enddo
6031       enddo
6032       call flush(iout)
6033       if (lprn) then
6034         write (iout,'(a)') 'Contact function values after receive:'
6035         do i=nnt,nct-2
6036           write (iout,'(2i3,50(1x,i3,f5.2))')
6037      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6038      &    j=1,num_cont_hb(i))
6039         enddo
6040         call flush(iout)
6041       endif
6042    30 continue
6043 #endif
6044       if (lprn) then
6045         write (iout,'(a)') 'Contact function values:'
6046         do i=nnt,nct-2
6047           write (iout,'(2i3,50(1x,i3,f5.2))')
6048      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6049      &    j=1,num_cont_hb(i))
6050         enddo
6051       endif
6052       ecorr=0.0D0
6053 C Remove the loop below after debugging !!!
6054       do i=nnt,nct
6055         do j=1,3
6056           gradcorr(j,i)=0.0D0
6057           gradxorr(j,i)=0.0D0
6058         enddo
6059       enddo
6060 C Calculate the local-electrostatic correlation terms
6061       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6062         i1=i+1
6063         num_conti=num_cont_hb(i)
6064         num_conti1=num_cont_hb(i+1)
6065         do jj=1,num_conti
6066           j=jcont_hb(jj,i)
6067           jp=iabs(j)
6068           do kk=1,num_conti1
6069             j1=jcont_hb(kk,i1)
6070             jp1=iabs(j1)
6071 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6072 c     &         ' jj=',jj,' kk=',kk
6073             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6074      &          .or. j.lt.0 .and. j1.gt.0) .and.
6075      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6076 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6077 C The system gains extra energy.
6078               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6079               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6080      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6081               n_corr=n_corr+1
6082             else if (j1.eq.j) then
6083 C Contacts I-J and I-(J+1) occur simultaneously.
6084 C The system loses extra energy.
6085 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6086             endif
6087           enddo ! kk
6088           do kk=1,num_conti
6089             j1=jcont_hb(kk,i)
6090 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6091 c    &         ' jj=',jj,' kk=',kk
6092             if (j1.eq.j+1) then
6093 C Contacts I-J and (I+1)-J occur simultaneously.
6094 C The system loses extra energy.
6095 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6096             endif ! j1==j+1
6097           enddo ! kk
6098         enddo ! jj
6099       enddo ! i
6100       return
6101       end
6102 c------------------------------------------------------------------------------
6103       subroutine add_hb_contact(ii,jj,itask)
6104       implicit real*8 (a-h,o-z)
6105       include "DIMENSIONS"
6106       include "COMMON.IOUNITS"
6107       integer max_cont
6108       integer max_dim
6109       parameter (max_cont=maxconts)
6110       parameter (max_dim=26)
6111       include "COMMON.CONTACTS"
6112       double precision zapas(max_dim,maxconts,max_fg_procs),
6113      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6114       common /przechowalnia/ zapas
6115       integer i,j,ii,jj,iproc,itask(4),nn
6116 c      write (iout,*) "itask",itask
6117       do i=1,2
6118         iproc=itask(i)
6119         if (iproc.gt.0) then
6120           do j=1,num_cont_hb(ii)
6121             jjc=jcont_hb(j,ii)
6122 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6123             if (jjc.eq.jj) then
6124               ncont_sent(iproc)=ncont_sent(iproc)+1
6125               nn=ncont_sent(iproc)
6126               zapas(1,nn,iproc)=ii
6127               zapas(2,nn,iproc)=jjc
6128               zapas(3,nn,iproc)=facont_hb(j,ii)
6129               zapas(4,nn,iproc)=ees0p(j,ii)
6130               zapas(5,nn,iproc)=ees0m(j,ii)
6131               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6132               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6133               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6134               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6135               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6136               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6137               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6138               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6139               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6140               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6141               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6142               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6143               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6144               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6145               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6146               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6147               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6148               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6149               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6150               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6151               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6152               exit
6153             endif
6154           enddo
6155         endif
6156       enddo
6157       return
6158       end
6159 c------------------------------------------------------------------------------
6160       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6161      &  n_corr1)
6162 C This subroutine calculates multi-body contributions to hydrogen-bonding
6163       implicit real*8 (a-h,o-z)
6164       include 'DIMENSIONS'
6165       include 'COMMON.IOUNITS'
6166 #ifdef MPI
6167       include "mpif.h"
6168       parameter (max_cont=maxconts)
6169       parameter (max_dim=70)
6170       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6171       double precision zapas(max_dim,maxconts,max_fg_procs),
6172      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6173       common /przechowalnia/ zapas
6174       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6175      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6176 #endif
6177       include 'COMMON.SETUP'
6178       include 'COMMON.FFIELD'
6179       include 'COMMON.DERIV'
6180       include 'COMMON.LOCAL'
6181       include 'COMMON.INTERACT'
6182       include 'COMMON.CONTACTS'
6183       include 'COMMON.CHAIN'
6184       include 'COMMON.CONTROL'
6185       double precision gx(3),gx1(3)
6186       integer num_cont_hb_old(maxres)
6187       logical lprn,ldone
6188       double precision eello4,eello5,eelo6,eello_turn6
6189       external eello4,eello5,eello6,eello_turn6
6190 C Set lprn=.true. for debugging
6191       lprn=.false.
6192       eturn6=0.0d0
6193 #ifdef MPI
6194       do i=1,nres
6195         num_cont_hb_old(i)=num_cont_hb(i)
6196       enddo
6197       n_corr=0
6198       n_corr1=0
6199       if (nfgtasks.le.1) goto 30
6200       if (lprn) then
6201         write (iout,'(a)') 'Contact function values before RECEIVE:'
6202         do i=nnt,nct-2
6203           write (iout,'(2i3,50(1x,i2,f5.2))')
6204      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6205      &    j=1,num_cont_hb(i))
6206         enddo
6207       endif
6208       call flush(iout)
6209       do i=1,ntask_cont_from
6210         ncont_recv(i)=0
6211       enddo
6212       do i=1,ntask_cont_to
6213         ncont_sent(i)=0
6214       enddo
6215 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6216 c     & ntask_cont_to
6217 C Make the list of contacts to send to send to other procesors
6218       do i=iturn3_start,iturn3_end
6219 c        write (iout,*) "make contact list turn3",i," num_cont",
6220 c     &    num_cont_hb(i)
6221         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6222       enddo
6223       do i=iturn4_start,iturn4_end
6224 c        write (iout,*) "make contact list turn4",i," num_cont",
6225 c     &   num_cont_hb(i)
6226         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6227       enddo
6228       do ii=1,nat_sent
6229         i=iat_sent(ii)
6230 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6231 c     &    num_cont_hb(i)
6232         do j=1,num_cont_hb(i)
6233         do k=1,4
6234           jjc=jcont_hb(j,i)
6235           iproc=iint_sent_local(k,jjc,ii)
6236 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6237           if (iproc.ne.0) then
6238             ncont_sent(iproc)=ncont_sent(iproc)+1
6239             nn=ncont_sent(iproc)
6240             zapas(1,nn,iproc)=i
6241             zapas(2,nn,iproc)=jjc
6242             zapas(3,nn,iproc)=d_cont(j,i)
6243             ind=3
6244             do kk=1,3
6245               ind=ind+1
6246               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6247             enddo
6248             do kk=1,2
6249               do ll=1,2
6250                 ind=ind+1
6251                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6252               enddo
6253             enddo
6254             do jj=1,5
6255               do kk=1,3
6256                 do ll=1,2
6257                   do mm=1,2
6258                     ind=ind+1
6259                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6260                   enddo
6261                 enddo
6262               enddo
6263             enddo
6264           endif
6265         enddo
6266         enddo
6267       enddo
6268       if (lprn) then
6269       write (iout,*)
6270      &  "Numbers of contacts to be sent to other processors",
6271      &  (ncont_sent(i),i=1,ntask_cont_to)
6272       write (iout,*) "Contacts sent"
6273       do ii=1,ntask_cont_to
6274         nn=ncont_sent(ii)
6275         iproc=itask_cont_to(ii)
6276         write (iout,*) nn," contacts to processor",iproc,
6277      &   " of CONT_TO_COMM group"
6278         do i=1,nn
6279           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6280         enddo
6281       enddo
6282       call flush(iout)
6283       endif
6284       CorrelType=477
6285       CorrelID=fg_rank+1
6286       CorrelType1=478
6287       CorrelID1=nfgtasks+fg_rank+1
6288       ireq=0
6289 C Receive the numbers of needed contacts from other processors
6290       do ii=1,ntask_cont_from
6291         iproc=itask_cont_from(ii)
6292         ireq=ireq+1
6293         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6294      &    FG_COMM,req(ireq),IERR)
6295       enddo
6296 c      write (iout,*) "IRECV ended"
6297 c      call flush(iout)
6298 C Send the number of contacts needed by other processors
6299       do ii=1,ntask_cont_to
6300         iproc=itask_cont_to(ii)
6301         ireq=ireq+1
6302         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6303      &    FG_COMM,req(ireq),IERR)
6304       enddo
6305 c      write (iout,*) "ISEND ended"
6306 c      write (iout,*) "number of requests (nn)",ireq
6307       call flush(iout)
6308       if (ireq.gt.0)
6309      &  call MPI_Waitall(ireq,req,status_array,ierr)
6310 c      write (iout,*)
6311 c     &  "Numbers of contacts to be received from other processors",
6312 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6313 c      call flush(iout)
6314 C Receive contacts
6315       ireq=0
6316       do ii=1,ntask_cont_from
6317         iproc=itask_cont_from(ii)
6318         nn=ncont_recv(ii)
6319 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6320 c     &   " of CONT_TO_COMM group"
6321         call flush(iout)
6322         if (nn.gt.0) then
6323           ireq=ireq+1
6324           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6325      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6326 c          write (iout,*) "ireq,req",ireq,req(ireq)
6327         endif
6328       enddo
6329 C Send the contacts to processors that need them
6330       do ii=1,ntask_cont_to
6331         iproc=itask_cont_to(ii)
6332         nn=ncont_sent(ii)
6333 c        write (iout,*) nn," contacts to processor",iproc,
6334 c     &   " of CONT_TO_COMM group"
6335         if (nn.gt.0) then
6336           ireq=ireq+1
6337           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6338      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6339 c          write (iout,*) "ireq,req",ireq,req(ireq)
6340 c          do i=1,nn
6341 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6342 c          enddo
6343         endif
6344       enddo
6345 c      write (iout,*) "number of requests (contacts)",ireq
6346 c      write (iout,*) "req",(req(i),i=1,4)
6347 c      call flush(iout)
6348       if (ireq.gt.0)
6349      & call MPI_Waitall(ireq,req,status_array,ierr)
6350       do iii=1,ntask_cont_from
6351         iproc=itask_cont_from(iii)
6352         nn=ncont_recv(iii)
6353         if (lprn) then
6354         write (iout,*) "Received",nn," contacts from processor",iproc,
6355      &   " of CONT_FROM_COMM group"
6356         call flush(iout)
6357         do i=1,nn
6358           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6359         enddo
6360         call flush(iout)
6361         endif
6362         do i=1,nn
6363           ii=zapas_recv(1,i,iii)
6364 c Flag the received contacts to prevent double-counting
6365           jj=-zapas_recv(2,i,iii)
6366 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6367 c          call flush(iout)
6368           nnn=num_cont_hb(ii)+1
6369           num_cont_hb(ii)=nnn
6370           jcont_hb(nnn,ii)=jj
6371           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6372           ind=3
6373           do kk=1,3
6374             ind=ind+1
6375             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6376           enddo
6377           do kk=1,2
6378             do ll=1,2
6379               ind=ind+1
6380               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6381             enddo
6382           enddo
6383           do jj=1,5
6384             do kk=1,3
6385               do ll=1,2
6386                 do mm=1,2
6387                   ind=ind+1
6388                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6389                 enddo
6390               enddo
6391             enddo
6392           enddo
6393         enddo
6394       enddo
6395       call flush(iout)
6396       if (lprn) then
6397         write (iout,'(a)') 'Contact function values after receive:'
6398         do i=nnt,nct-2
6399           write (iout,'(2i3,50(1x,i3,5f6.3))')
6400      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6401      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6402         enddo
6403         call flush(iout)
6404       endif
6405    30 continue
6406 #endif
6407       if (lprn) then
6408         write (iout,'(a)') 'Contact function values:'
6409         do i=nnt,nct-2
6410           write (iout,'(2i3,50(1x,i2,5f6.3))')
6411      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6412      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6413         enddo
6414       endif
6415       ecorr=0.0D0
6416       ecorr5=0.0d0
6417       ecorr6=0.0d0
6418 C Remove the loop below after debugging !!!
6419       do i=nnt,nct
6420         do j=1,3
6421           gradcorr(j,i)=0.0D0
6422           gradxorr(j,i)=0.0D0
6423         enddo
6424       enddo
6425 C Calculate the dipole-dipole interaction energies
6426       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6427       do i=iatel_s,iatel_e+1
6428         num_conti=num_cont_hb(i)
6429         do jj=1,num_conti
6430           j=jcont_hb(jj,i)
6431 #ifdef MOMENT
6432           call dipole(i,j,jj)
6433 #endif
6434         enddo
6435       enddo
6436       endif
6437 C Calculate the local-electrostatic correlation terms
6438 c                write (iout,*) "gradcorr5 in eello5 before loop"
6439 c                do iii=1,nres
6440 c                  write (iout,'(i5,3f10.5)')
6441 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6442 c                enddo
6443       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6444 c        write (iout,*) "corr loop i",i
6445         i1=i+1
6446         num_conti=num_cont_hb(i)
6447         num_conti1=num_cont_hb(i+1)
6448         do jj=1,num_conti
6449           j=jcont_hb(jj,i)
6450           jp=iabs(j)
6451           do kk=1,num_conti1
6452             j1=jcont_hb(kk,i1)
6453             jp1=iabs(j1)
6454 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6455 c     &         ' jj=',jj,' kk=',kk
6456 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6457             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6458      &          .or. j.lt.0 .and. j1.gt.0) .and.
6459      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6460 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6461 C The system gains extra energy.
6462               n_corr=n_corr+1
6463               sqd1=dsqrt(d_cont(jj,i))
6464               sqd2=dsqrt(d_cont(kk,i1))
6465               sred_geom = sqd1*sqd2
6466               IF (sred_geom.lt.cutoff_corr) THEN
6467                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6468      &            ekont,fprimcont)
6469 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6470 cd     &         ' jj=',jj,' kk=',kk
6471                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6472                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6473                 do l=1,3
6474                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6475                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6476                 enddo
6477                 n_corr1=n_corr1+1
6478 cd               write (iout,*) 'sred_geom=',sred_geom,
6479 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6480 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6481 cd               write (iout,*) "g_contij",g_contij
6482 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6483 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6484                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6485                 if (wcorr4.gt.0.0d0)
6486      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6487                   if (energy_dec.and.wcorr4.gt.0.0d0)
6488      1                 write (iout,'(a6,4i5,0pf7.3)')
6489      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6490 c                write (iout,*) "gradcorr5 before eello5"
6491 c                do iii=1,nres
6492 c                  write (iout,'(i5,3f10.5)')
6493 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6494 c                enddo
6495                 if (wcorr5.gt.0.0d0)
6496      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6497 c                write (iout,*) "gradcorr5 after eello5"
6498 c                do iii=1,nres
6499 c                  write (iout,'(i5,3f10.5)')
6500 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6501 c                enddo
6502                   if (energy_dec.and.wcorr5.gt.0.0d0)
6503      1                 write (iout,'(a6,4i5,0pf7.3)')
6504      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6505 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6506 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6507                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6508      &               .or. wturn6.eq.0.0d0))then
6509 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6510                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6511                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6512      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6513 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6514 cd     &            'ecorr6=',ecorr6
6515 cd                write (iout,'(4e15.5)') sred_geom,
6516 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6517 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6518 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6519                 else if (wturn6.gt.0.0d0
6520      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6521 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6522                   eturn6=eturn6+eello_turn6(i,jj,kk)
6523                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6524      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6525 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6526                 endif
6527               ENDIF
6528 1111          continue
6529             endif
6530           enddo ! kk
6531         enddo ! jj
6532       enddo ! i
6533       do i=1,nres
6534         num_cont_hb(i)=num_cont_hb_old(i)
6535       enddo
6536 c                write (iout,*) "gradcorr5 in eello5"
6537 c                do iii=1,nres
6538 c                  write (iout,'(i5,3f10.5)')
6539 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6540 c                enddo
6541       return
6542       end
6543 c------------------------------------------------------------------------------
6544       subroutine add_hb_contact_eello(ii,jj,itask)
6545       implicit real*8 (a-h,o-z)
6546       include "DIMENSIONS"
6547       include "COMMON.IOUNITS"
6548       integer max_cont
6549       integer max_dim
6550       parameter (max_cont=maxconts)
6551       parameter (max_dim=70)
6552       include "COMMON.CONTACTS"
6553       double precision zapas(max_dim,maxconts,max_fg_procs),
6554      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6555       common /przechowalnia/ zapas
6556       integer i,j,ii,jj,iproc,itask(4),nn
6557 c      write (iout,*) "itask",itask
6558       do i=1,2
6559         iproc=itask(i)
6560         if (iproc.gt.0) then
6561           do j=1,num_cont_hb(ii)
6562             jjc=jcont_hb(j,ii)
6563 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6564             if (jjc.eq.jj) then
6565               ncont_sent(iproc)=ncont_sent(iproc)+1
6566               nn=ncont_sent(iproc)
6567               zapas(1,nn,iproc)=ii
6568               zapas(2,nn,iproc)=jjc
6569               zapas(3,nn,iproc)=d_cont(j,ii)
6570               ind=3
6571               do kk=1,3
6572                 ind=ind+1
6573                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6574               enddo
6575               do kk=1,2
6576                 do ll=1,2
6577                   ind=ind+1
6578                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6579                 enddo
6580               enddo
6581               do jj=1,5
6582                 do kk=1,3
6583                   do ll=1,2
6584                     do mm=1,2
6585                       ind=ind+1
6586                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6587                     enddo
6588                   enddo
6589                 enddo
6590               enddo
6591               exit
6592             endif
6593           enddo
6594         endif
6595       enddo
6596       return
6597       end
6598 c------------------------------------------------------------------------------
6599       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6600       implicit real*8 (a-h,o-z)
6601       include 'DIMENSIONS'
6602       include 'COMMON.IOUNITS'
6603       include 'COMMON.DERIV'
6604       include 'COMMON.INTERACT'
6605       include 'COMMON.CONTACTS'
6606       double precision gx(3),gx1(3)
6607       logical lprn
6608       lprn=.false.
6609       eij=facont_hb(jj,i)
6610       ekl=facont_hb(kk,k)
6611       ees0pij=ees0p(jj,i)
6612       ees0pkl=ees0p(kk,k)
6613       ees0mij=ees0m(jj,i)
6614       ees0mkl=ees0m(kk,k)
6615       ekont=eij*ekl
6616       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6617 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6618 C Following 4 lines for diagnostics.
6619 cd    ees0pkl=0.0D0
6620 cd    ees0pij=1.0D0
6621 cd    ees0mkl=0.0D0
6622 cd    ees0mij=1.0D0
6623 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6624 c     & 'Contacts ',i,j,
6625 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6626 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6627 c     & 'gradcorr_long'
6628 C Calculate the multi-body contribution to energy.
6629 c      ecorr=ecorr+ekont*ees
6630 C Calculate multi-body contributions to the gradient.
6631       coeffpees0pij=coeffp*ees0pij
6632       coeffmees0mij=coeffm*ees0mij
6633       coeffpees0pkl=coeffp*ees0pkl
6634       coeffmees0mkl=coeffm*ees0mkl
6635       do ll=1,3
6636 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6637         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6638      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6639      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6640         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6641      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6642      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6643 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6644         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6645      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6646      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6647         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6648      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6649      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6650         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6651      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6652      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6653         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6654         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6655         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6656      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6657      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6658         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6659         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6660 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6661       enddo
6662 c      write (iout,*)
6663 cgrad      do m=i+1,j-1
6664 cgrad        do ll=1,3
6665 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6666 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6667 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6668 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6669 cgrad        enddo
6670 cgrad      enddo
6671 cgrad      do m=k+1,l-1
6672 cgrad        do ll=1,3
6673 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6674 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6675 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6676 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6677 cgrad        enddo
6678 cgrad      enddo
6679 c      write (iout,*) "ehbcorr",ekont*ees
6680       ehbcorr=ekont*ees
6681       return
6682       end
6683 #ifdef MOMENT
6684 C---------------------------------------------------------------------------
6685       subroutine dipole(i,j,jj)
6686       implicit real*8 (a-h,o-z)
6687       include 'DIMENSIONS'
6688       include 'COMMON.IOUNITS'
6689       include 'COMMON.CHAIN'
6690       include 'COMMON.FFIELD'
6691       include 'COMMON.DERIV'
6692       include 'COMMON.INTERACT'
6693       include 'COMMON.CONTACTS'
6694       include 'COMMON.TORSION'
6695       include 'COMMON.VAR'
6696       include 'COMMON.GEO'
6697       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6698      &  auxmat(2,2)
6699       iti1 = itortyp(itype(i+1))
6700       if (j.lt.nres-1) then
6701         itj1 = itortyp(itype(j+1))
6702       else
6703         itj1=ntortyp+1
6704       endif
6705       do iii=1,2
6706         dipi(iii,1)=Ub2(iii,i)
6707         dipderi(iii)=Ub2der(iii,i)
6708         dipi(iii,2)=b1(iii,iti1)
6709         dipj(iii,1)=Ub2(iii,j)
6710         dipderj(iii)=Ub2der(iii,j)
6711         dipj(iii,2)=b1(iii,itj1)
6712       enddo
6713       kkk=0
6714       do iii=1,2
6715         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6716         do jjj=1,2
6717           kkk=kkk+1
6718           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6719         enddo
6720       enddo
6721       do kkk=1,5
6722         do lll=1,3
6723           mmm=0
6724           do iii=1,2
6725             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6726      &        auxvec(1))
6727             do jjj=1,2
6728               mmm=mmm+1
6729               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6730             enddo
6731           enddo
6732         enddo
6733       enddo
6734       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6735       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6736       do iii=1,2
6737         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6738       enddo
6739       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6740       do iii=1,2
6741         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6742       enddo
6743       return
6744       end
6745 #endif
6746 C---------------------------------------------------------------------------
6747       subroutine calc_eello(i,j,k,l,jj,kk)
6748 C
6749 C This subroutine computes matrices and vectors needed to calculate
6750 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6751 C
6752       implicit real*8 (a-h,o-z)
6753       include 'DIMENSIONS'
6754       include 'COMMON.IOUNITS'
6755       include 'COMMON.CHAIN'
6756       include 'COMMON.DERIV'
6757       include 'COMMON.INTERACT'
6758       include 'COMMON.CONTACTS'
6759       include 'COMMON.TORSION'
6760       include 'COMMON.VAR'
6761       include 'COMMON.GEO'
6762       include 'COMMON.FFIELD'
6763       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6764      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6765       logical lprn
6766       common /kutas/ lprn
6767 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6768 cd     & ' jj=',jj,' kk=',kk
6769 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6770 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6771 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6772       do iii=1,2
6773         do jjj=1,2
6774           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6775           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6776         enddo
6777       enddo
6778       call transpose2(aa1(1,1),aa1t(1,1))
6779       call transpose2(aa2(1,1),aa2t(1,1))
6780       do kkk=1,5
6781         do lll=1,3
6782           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6783      &      aa1tder(1,1,lll,kkk))
6784           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6785      &      aa2tder(1,1,lll,kkk))
6786         enddo
6787       enddo
6788       if (l.eq.j+1) then
6789 C parallel orientation of the two CA-CA-CA frames.
6790         if (i.gt.1) then
6791           iti=itortyp(itype(i))
6792         else
6793           iti=ntortyp+1
6794         endif
6795         itk1=itortyp(itype(k+1))
6796         itj=itortyp(itype(j))
6797         if (l.lt.nres-1) then
6798           itl1=itortyp(itype(l+1))
6799         else
6800           itl1=ntortyp+1
6801         endif
6802 C A1 kernel(j+1) A2T
6803 cd        do iii=1,2
6804 cd          write (iout,'(3f10.5,5x,3f10.5)')
6805 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6806 cd        enddo
6807         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6808      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6809      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6810 C Following matrices are needed only for 6-th order cumulants
6811         IF (wcorr6.gt.0.0d0) THEN
6812         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6813      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6814      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6815         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6816      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6817      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6818      &   ADtEAderx(1,1,1,1,1,1))
6819         lprn=.false.
6820         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6821      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6822      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6823      &   ADtEA1derx(1,1,1,1,1,1))
6824         ENDIF
6825 C End 6-th order cumulants
6826 cd        lprn=.false.
6827 cd        if (lprn) then
6828 cd        write (2,*) 'In calc_eello6'
6829 cd        do iii=1,2
6830 cd          write (2,*) 'iii=',iii
6831 cd          do kkk=1,5
6832 cd            write (2,*) 'kkk=',kkk
6833 cd            do jjj=1,2
6834 cd              write (2,'(3(2f10.5),5x)')
6835 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6836 cd            enddo
6837 cd          enddo
6838 cd        enddo
6839 cd        endif
6840         call transpose2(EUgder(1,1,k),auxmat(1,1))
6841         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6842         call transpose2(EUg(1,1,k),auxmat(1,1))
6843         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6844         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6845         do iii=1,2
6846           do kkk=1,5
6847             do lll=1,3
6848               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6849      &          EAEAderx(1,1,lll,kkk,iii,1))
6850             enddo
6851           enddo
6852         enddo
6853 C A1T kernel(i+1) A2
6854         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6855      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6856      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6857 C Following matrices are needed only for 6-th order cumulants
6858         IF (wcorr6.gt.0.0d0) THEN
6859         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6860      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6861      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6862         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6863      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6864      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6865      &   ADtEAderx(1,1,1,1,1,2))
6866         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6867      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6868      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6869      &   ADtEA1derx(1,1,1,1,1,2))
6870         ENDIF
6871 C End 6-th order cumulants
6872         call transpose2(EUgder(1,1,l),auxmat(1,1))
6873         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6874         call transpose2(EUg(1,1,l),auxmat(1,1))
6875         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6876         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6877         do iii=1,2
6878           do kkk=1,5
6879             do lll=1,3
6880               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6881      &          EAEAderx(1,1,lll,kkk,iii,2))
6882             enddo
6883           enddo
6884         enddo
6885 C AEAb1 and AEAb2
6886 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6887 C They are needed only when the fifth- or the sixth-order cumulants are
6888 C indluded.
6889         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6890         call transpose2(AEA(1,1,1),auxmat(1,1))
6891         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6892         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6893         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6894         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6895         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6896         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6897         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6898         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6899         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6900         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6901         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6902         call transpose2(AEA(1,1,2),auxmat(1,1))
6903         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6904         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6905         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6906         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6907         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6908         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6909         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6910         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6911         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6912         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6913         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6914 C Calculate the Cartesian derivatives of the vectors.
6915         do iii=1,2
6916           do kkk=1,5
6917             do lll=1,3
6918               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6919               call matvec2(auxmat(1,1),b1(1,iti),
6920      &          AEAb1derx(1,lll,kkk,iii,1,1))
6921               call matvec2(auxmat(1,1),Ub2(1,i),
6922      &          AEAb2derx(1,lll,kkk,iii,1,1))
6923               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6924      &          AEAb1derx(1,lll,kkk,iii,2,1))
6925               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6926      &          AEAb2derx(1,lll,kkk,iii,2,1))
6927               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6928               call matvec2(auxmat(1,1),b1(1,itj),
6929      &          AEAb1derx(1,lll,kkk,iii,1,2))
6930               call matvec2(auxmat(1,1),Ub2(1,j),
6931      &          AEAb2derx(1,lll,kkk,iii,1,2))
6932               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6933      &          AEAb1derx(1,lll,kkk,iii,2,2))
6934               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6935      &          AEAb2derx(1,lll,kkk,iii,2,2))
6936             enddo
6937           enddo
6938         enddo
6939         ENDIF
6940 C End vectors
6941       else
6942 C Antiparallel orientation of the two CA-CA-CA frames.
6943         if (i.gt.1) then
6944           iti=itortyp(itype(i))
6945         else
6946           iti=ntortyp+1
6947         endif
6948         itk1=itortyp(itype(k+1))
6949         itl=itortyp(itype(l))
6950         itj=itortyp(itype(j))
6951         if (j.lt.nres-1) then
6952           itj1=itortyp(itype(j+1))
6953         else
6954           itj1=ntortyp+1
6955         endif
6956 C A2 kernel(j-1)T A1T
6957         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6958      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6959      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6960 C Following matrices are needed only for 6-th order cumulants
6961         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6962      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6963         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6964      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6965      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6966         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6967      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6968      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6969      &   ADtEAderx(1,1,1,1,1,1))
6970         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6971      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6972      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6973      &   ADtEA1derx(1,1,1,1,1,1))
6974         ENDIF
6975 C End 6-th order cumulants
6976         call transpose2(EUgder(1,1,k),auxmat(1,1))
6977         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6978         call transpose2(EUg(1,1,k),auxmat(1,1))
6979         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6980         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6981         do iii=1,2
6982           do kkk=1,5
6983             do lll=1,3
6984               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6985      &          EAEAderx(1,1,lll,kkk,iii,1))
6986             enddo
6987           enddo
6988         enddo
6989 C A2T kernel(i+1)T A1
6990         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6991      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6992      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
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(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6997      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6998      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6999         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7000      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7001      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7002      &   ADtEAderx(1,1,1,1,1,2))
7003         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7004      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7005      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7006      &   ADtEA1derx(1,1,1,1,1,2))
7007         ENDIF
7008 C End 6-th order cumulants
7009         call transpose2(EUgder(1,1,j),auxmat(1,1))
7010         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7011         call transpose2(EUg(1,1,j),auxmat(1,1))
7012         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7013         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
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,2),
7018      &          EAEAderx(1,1,lll,kkk,iii,2))
7019             enddo
7020           enddo
7021         enddo
7022 C AEAb1 and AEAb2
7023 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7024 C They are needed only when the fifth- or the sixth-order cumulants are
7025 C indluded.
7026         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7027      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7028         call transpose2(AEA(1,1,1),auxmat(1,1))
7029         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7030         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7031         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7032         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7033         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7034         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7035         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7036         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7037         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7038         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7039         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7040         call transpose2(AEA(1,1,2),auxmat(1,1))
7041         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7042         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7043         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7044         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7045         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7046         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7047         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7048         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7049         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7050         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7051         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7052 C Calculate the Cartesian derivatives of the vectors.
7053         do iii=1,2
7054           do kkk=1,5
7055             do lll=1,3
7056               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7057               call matvec2(auxmat(1,1),b1(1,iti),
7058      &          AEAb1derx(1,lll,kkk,iii,1,1))
7059               call matvec2(auxmat(1,1),Ub2(1,i),
7060      &          AEAb2derx(1,lll,kkk,iii,1,1))
7061               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7062      &          AEAb1derx(1,lll,kkk,iii,2,1))
7063               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7064      &          AEAb2derx(1,lll,kkk,iii,2,1))
7065               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7066               call matvec2(auxmat(1,1),b1(1,itl),
7067      &          AEAb1derx(1,lll,kkk,iii,1,2))
7068               call matvec2(auxmat(1,1),Ub2(1,l),
7069      &          AEAb2derx(1,lll,kkk,iii,1,2))
7070               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7071      &          AEAb1derx(1,lll,kkk,iii,2,2))
7072               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7073      &          AEAb2derx(1,lll,kkk,iii,2,2))
7074             enddo
7075           enddo
7076         enddo
7077         ENDIF
7078 C End vectors
7079       endif
7080       return
7081       end
7082 C---------------------------------------------------------------------------
7083       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7084      &  KK,KKderg,AKA,AKAderg,AKAderx)
7085       implicit none
7086       integer nderg
7087       logical transp
7088       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7089      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7090      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7091       integer iii,kkk,lll
7092       integer jjj,mmm
7093       logical lprn
7094       common /kutas/ lprn
7095       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7096       do iii=1,nderg
7097         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7098      &    AKAderg(1,1,iii))
7099       enddo
7100 cd      if (lprn) write (2,*) 'In kernel'
7101       do kkk=1,5
7102 cd        if (lprn) write (2,*) 'kkk=',kkk
7103         do lll=1,3
7104           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7105      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7106 cd          if (lprn) then
7107 cd            write (2,*) 'lll=',lll
7108 cd            write (2,*) 'iii=1'
7109 cd            do jjj=1,2
7110 cd              write (2,'(3(2f10.5),5x)')
7111 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7112 cd            enddo
7113 cd          endif
7114           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7115      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7116 cd          if (lprn) then
7117 cd            write (2,*) 'lll=',lll
7118 cd            write (2,*) 'iii=2'
7119 cd            do jjj=1,2
7120 cd              write (2,'(3(2f10.5),5x)')
7121 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7122 cd            enddo
7123 cd          endif
7124         enddo
7125       enddo
7126       return
7127       end
7128 C---------------------------------------------------------------------------
7129       double precision function eello4(i,j,k,l,jj,kk)
7130       implicit real*8 (a-h,o-z)
7131       include 'DIMENSIONS'
7132       include 'COMMON.IOUNITS'
7133       include 'COMMON.CHAIN'
7134       include 'COMMON.DERIV'
7135       include 'COMMON.INTERACT'
7136       include 'COMMON.CONTACTS'
7137       include 'COMMON.TORSION'
7138       include 'COMMON.VAR'
7139       include 'COMMON.GEO'
7140       double precision pizda(2,2),ggg1(3),ggg2(3)
7141 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7142 cd        eello4=0.0d0
7143 cd        return
7144 cd      endif
7145 cd      print *,'eello4:',i,j,k,l,jj,kk
7146 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7147 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7148 cold      eij=facont_hb(jj,i)
7149 cold      ekl=facont_hb(kk,k)
7150 cold      ekont=eij*ekl
7151       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7152 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7153       gcorr_loc(k-1)=gcorr_loc(k-1)
7154      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7155       if (l.eq.j+1) then
7156         gcorr_loc(l-1)=gcorr_loc(l-1)
7157      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7158       else
7159         gcorr_loc(j-1)=gcorr_loc(j-1)
7160      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7161       endif
7162       do iii=1,2
7163         do kkk=1,5
7164           do lll=1,3
7165             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7166      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7167 cd            derx(lll,kkk,iii)=0.0d0
7168           enddo
7169         enddo
7170       enddo
7171 cd      gcorr_loc(l-1)=0.0d0
7172 cd      gcorr_loc(j-1)=0.0d0
7173 cd      gcorr_loc(k-1)=0.0d0
7174 cd      eel4=1.0d0
7175 cd      write (iout,*)'Contacts have occurred for peptide groups',
7176 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7177 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7178       if (j.lt.nres-1) then
7179         j1=j+1
7180         j2=j-1
7181       else
7182         j1=j-1
7183         j2=j-2
7184       endif
7185       if (l.lt.nres-1) then
7186         l1=l+1
7187         l2=l-1
7188       else
7189         l1=l-1
7190         l2=l-2
7191       endif
7192       do ll=1,3
7193 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7194 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7195         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7196         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7197 cgrad        ghalf=0.5d0*ggg1(ll)
7198         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7199         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7200         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7201         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7202         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7203         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7204 cgrad        ghalf=0.5d0*ggg2(ll)
7205         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7206         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7207         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7208         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7209         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7210         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7211       enddo
7212 cgrad      do m=i+1,j-1
7213 cgrad        do ll=1,3
7214 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7215 cgrad        enddo
7216 cgrad      enddo
7217 cgrad      do m=k+1,l-1
7218 cgrad        do ll=1,3
7219 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7220 cgrad        enddo
7221 cgrad      enddo
7222 cgrad      do m=i+2,j2
7223 cgrad        do ll=1,3
7224 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7225 cgrad        enddo
7226 cgrad      enddo
7227 cgrad      do m=k+2,l2
7228 cgrad        do ll=1,3
7229 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7230 cgrad        enddo
7231 cgrad      enddo
7232 cd      do iii=1,nres-3
7233 cd        write (2,*) iii,gcorr_loc(iii)
7234 cd      enddo
7235       eello4=ekont*eel4
7236 cd      write (2,*) 'ekont',ekont
7237 cd      write (iout,*) 'eello4',ekont*eel4
7238       return
7239       end
7240 C---------------------------------------------------------------------------
7241       double precision function eello5(i,j,k,l,jj,kk)
7242       implicit real*8 (a-h,o-z)
7243       include 'DIMENSIONS'
7244       include 'COMMON.IOUNITS'
7245       include 'COMMON.CHAIN'
7246       include 'COMMON.DERIV'
7247       include 'COMMON.INTERACT'
7248       include 'COMMON.CONTACTS'
7249       include 'COMMON.TORSION'
7250       include 'COMMON.VAR'
7251       include 'COMMON.GEO'
7252       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7253       double precision ggg1(3),ggg2(3)
7254 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7255 C                                                                              C
7256 C                            Parallel chains                                   C
7257 C                                                                              C
7258 C          o             o                   o             o                   C
7259 C         /l\           / \             \   / \           / \   /              C
7260 C        /   \         /   \             \ /   \         /   \ /               C
7261 C       j| o |l1       | o |              o| o |         | o |o                C
7262 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7263 C      \i/   \         /   \ /             /   \         /   \                 C
7264 C       o    k1             o                                                  C
7265 C         (I)          (II)                (III)          (IV)                 C
7266 C                                                                              C
7267 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7268 C                                                                              C
7269 C                            Antiparallel chains                               C
7270 C                                                                              C
7271 C          o             o                   o             o                   C
7272 C         /j\           / \             \   / \           / \   /              C
7273 C        /   \         /   \             \ /   \         /   \ /               C
7274 C      j1| o |l        | o |              o| o |         | o |o                C
7275 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7276 C      \i/   \         /   \ /             /   \         /   \                 C
7277 C       o     k1            o                                                  C
7278 C         (I)          (II)                (III)          (IV)                 C
7279 C                                                                              C
7280 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7281 C                                                                              C
7282 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7283 C                                                                              C
7284 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7285 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7286 cd        eello5=0.0d0
7287 cd        return
7288 cd      endif
7289 cd      write (iout,*)
7290 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7291 cd     &   ' and',k,l
7292       itk=itortyp(itype(k))
7293       itl=itortyp(itype(l))
7294       itj=itortyp(itype(j))
7295       eello5_1=0.0d0
7296       eello5_2=0.0d0
7297       eello5_3=0.0d0
7298       eello5_4=0.0d0
7299 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7300 cd     &   eel5_3_num,eel5_4_num)
7301       do iii=1,2
7302         do kkk=1,5
7303           do lll=1,3
7304             derx(lll,kkk,iii)=0.0d0
7305           enddo
7306         enddo
7307       enddo
7308 cd      eij=facont_hb(jj,i)
7309 cd      ekl=facont_hb(kk,k)
7310 cd      ekont=eij*ekl
7311 cd      write (iout,*)'Contacts have occurred for peptide groups',
7312 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7313 cd      goto 1111
7314 C Contribution from the graph I.
7315 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7316 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7317       call transpose2(EUg(1,1,k),auxmat(1,1))
7318       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7319       vv(1)=pizda(1,1)-pizda(2,2)
7320       vv(2)=pizda(1,2)+pizda(2,1)
7321       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7322      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7323 C Explicit gradient in virtual-dihedral angles.
7324       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7325      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7326      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7327       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7328       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7329       vv(1)=pizda(1,1)-pizda(2,2)
7330       vv(2)=pizda(1,2)+pizda(2,1)
7331       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7332      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7333      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7334       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7335       vv(1)=pizda(1,1)-pizda(2,2)
7336       vv(2)=pizda(1,2)+pizda(2,1)
7337       if (l.eq.j+1) then
7338         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7339      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7340      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7341       else
7342         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7343      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7344      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7345       endif
7346 C Cartesian gradient
7347       do iii=1,2
7348         do kkk=1,5
7349           do lll=1,3
7350             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7351      &        pizda(1,1))
7352             vv(1)=pizda(1,1)-pizda(2,2)
7353             vv(2)=pizda(1,2)+pizda(2,1)
7354             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7355      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7356      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7357           enddo
7358         enddo
7359       enddo
7360 c      goto 1112
7361 c1111  continue
7362 C Contribution from graph II
7363       call transpose2(EE(1,1,itk),auxmat(1,1))
7364       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7365       vv(1)=pizda(1,1)+pizda(2,2)
7366       vv(2)=pizda(2,1)-pizda(1,2)
7367       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7368      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7369 C Explicit gradient in virtual-dihedral angles.
7370       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7371      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7372       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7373       vv(1)=pizda(1,1)+pizda(2,2)
7374       vv(2)=pizda(2,1)-pizda(1,2)
7375       if (l.eq.j+1) then
7376         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7377      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7378      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7379       else
7380         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7381      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7382      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7383       endif
7384 C Cartesian gradient
7385       do iii=1,2
7386         do kkk=1,5
7387           do lll=1,3
7388             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7389      &        pizda(1,1))
7390             vv(1)=pizda(1,1)+pizda(2,2)
7391             vv(2)=pizda(2,1)-pizda(1,2)
7392             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7393      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7394      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7395           enddo
7396         enddo
7397       enddo
7398 cd      goto 1112
7399 cd1111  continue
7400       if (l.eq.j+1) then
7401 cd        goto 1110
7402 C Parallel orientation
7403 C Contribution from graph III
7404         call transpose2(EUg(1,1,l),auxmat(1,1))
7405         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7406         vv(1)=pizda(1,1)-pizda(2,2)
7407         vv(2)=pizda(1,2)+pizda(2,1)
7408         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7409      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7410 C Explicit gradient in virtual-dihedral angles.
7411         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7412      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7413      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7414         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7415         vv(1)=pizda(1,1)-pizda(2,2)
7416         vv(2)=pizda(1,2)+pizda(2,1)
7417         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7418      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7419      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7420         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7421         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7422         vv(1)=pizda(1,1)-pizda(2,2)
7423         vv(2)=pizda(1,2)+pizda(2,1)
7424         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7425      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7426      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7427 C Cartesian gradient
7428         do iii=1,2
7429           do kkk=1,5
7430             do lll=1,3
7431               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7432      &          pizda(1,1))
7433               vv(1)=pizda(1,1)-pizda(2,2)
7434               vv(2)=pizda(1,2)+pizda(2,1)
7435               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7436      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7437      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7438             enddo
7439           enddo
7440         enddo
7441 cd        goto 1112
7442 C Contribution from graph IV
7443 cd1110    continue
7444         call transpose2(EE(1,1,itl),auxmat(1,1))
7445         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7446         vv(1)=pizda(1,1)+pizda(2,2)
7447         vv(2)=pizda(2,1)-pizda(1,2)
7448         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7449      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7450 C Explicit gradient in virtual-dihedral angles.
7451         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7452      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7453         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7454         vv(1)=pizda(1,1)+pizda(2,2)
7455         vv(2)=pizda(2,1)-pizda(1,2)
7456         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7457      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7458      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7459 C Cartesian gradient
7460         do iii=1,2
7461           do kkk=1,5
7462             do lll=1,3
7463               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7464      &          pizda(1,1))
7465               vv(1)=pizda(1,1)+pizda(2,2)
7466               vv(2)=pizda(2,1)-pizda(1,2)
7467               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7468      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7469      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7470             enddo
7471           enddo
7472         enddo
7473       else
7474 C Antiparallel orientation
7475 C Contribution from graph III
7476 c        goto 1110
7477         call transpose2(EUg(1,1,j),auxmat(1,1))
7478         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7479         vv(1)=pizda(1,1)-pizda(2,2)
7480         vv(2)=pizda(1,2)+pizda(2,1)
7481         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7482      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7483 C Explicit gradient in virtual-dihedral angles.
7484         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7485      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7486      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7487         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7488         vv(1)=pizda(1,1)-pizda(2,2)
7489         vv(2)=pizda(1,2)+pizda(2,1)
7490         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7491      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7492      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7493         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7494         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7495         vv(1)=pizda(1,1)-pizda(2,2)
7496         vv(2)=pizda(1,2)+pizda(2,1)
7497         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7498      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7499      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7500 C Cartesian gradient
7501         do iii=1,2
7502           do kkk=1,5
7503             do lll=1,3
7504               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7505      &          pizda(1,1))
7506               vv(1)=pizda(1,1)-pizda(2,2)
7507               vv(2)=pizda(1,2)+pizda(2,1)
7508               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7509      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7510      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7511             enddo
7512           enddo
7513         enddo
7514 cd        goto 1112
7515 C Contribution from graph IV
7516 1110    continue
7517         call transpose2(EE(1,1,itj),auxmat(1,1))
7518         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7519         vv(1)=pizda(1,1)+pizda(2,2)
7520         vv(2)=pizda(2,1)-pizda(1,2)
7521         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7522      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7523 C Explicit gradient in virtual-dihedral angles.
7524         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7525      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7526         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7527         vv(1)=pizda(1,1)+pizda(2,2)
7528         vv(2)=pizda(2,1)-pizda(1,2)
7529         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7530      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7531      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7532 C Cartesian gradient
7533         do iii=1,2
7534           do kkk=1,5
7535             do lll=1,3
7536               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7537      &          pizda(1,1))
7538               vv(1)=pizda(1,1)+pizda(2,2)
7539               vv(2)=pizda(2,1)-pizda(1,2)
7540               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7541      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7542      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7543             enddo
7544           enddo
7545         enddo
7546       endif
7547 1112  continue
7548       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7549 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7550 cd        write (2,*) 'ijkl',i,j,k,l
7551 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7552 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7553 cd      endif
7554 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7555 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7556 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7557 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7558       if (j.lt.nres-1) then
7559         j1=j+1
7560         j2=j-1
7561       else
7562         j1=j-1
7563         j2=j-2
7564       endif
7565       if (l.lt.nres-1) then
7566         l1=l+1
7567         l2=l-1
7568       else
7569         l1=l-1
7570         l2=l-2
7571       endif
7572 cd      eij=1.0d0
7573 cd      ekl=1.0d0
7574 cd      ekont=1.0d0
7575 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7576 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7577 C        summed up outside the subrouine as for the other subroutines
7578 C        handling long-range interactions. The old code is commented out
7579 C        with "cgrad" to keep track of changes.
7580       do ll=1,3
7581 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7582 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7583         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7584         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7585 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7586 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7587 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7588 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7589 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7590 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7591 c     &   gradcorr5ij,
7592 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7593 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7594 cgrad        ghalf=0.5d0*ggg1(ll)
7595 cd        ghalf=0.0d0
7596         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7597         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7598         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7599         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7600         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7601         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7602 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7603 cgrad        ghalf=0.5d0*ggg2(ll)
7604 cd        ghalf=0.0d0
7605         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7606         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7607         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7608         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7609         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7610         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7611       enddo
7612 cd      goto 1112
7613 cgrad      do m=i+1,j-1
7614 cgrad        do ll=1,3
7615 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7616 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7617 cgrad        enddo
7618 cgrad      enddo
7619 cgrad      do m=k+1,l-1
7620 cgrad        do ll=1,3
7621 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7622 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7623 cgrad        enddo
7624 cgrad      enddo
7625 c1112  continue
7626 cgrad      do m=i+2,j2
7627 cgrad        do ll=1,3
7628 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7629 cgrad        enddo
7630 cgrad      enddo
7631 cgrad      do m=k+2,l2
7632 cgrad        do ll=1,3
7633 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7634 cgrad        enddo
7635 cgrad      enddo
7636 cd      do iii=1,nres-3
7637 cd        write (2,*) iii,g_corr5_loc(iii)
7638 cd      enddo
7639       eello5=ekont*eel5
7640 cd      write (2,*) 'ekont',ekont
7641 cd      write (iout,*) 'eello5',ekont*eel5
7642       return
7643       end
7644 c--------------------------------------------------------------------------
7645       double precision function eello6(i,j,k,l,jj,kk)
7646       implicit real*8 (a-h,o-z)
7647       include 'DIMENSIONS'
7648       include 'COMMON.IOUNITS'
7649       include 'COMMON.CHAIN'
7650       include 'COMMON.DERIV'
7651       include 'COMMON.INTERACT'
7652       include 'COMMON.CONTACTS'
7653       include 'COMMON.TORSION'
7654       include 'COMMON.VAR'
7655       include 'COMMON.GEO'
7656       include 'COMMON.FFIELD'
7657       double precision ggg1(3),ggg2(3)
7658 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7659 cd        eello6=0.0d0
7660 cd        return
7661 cd      endif
7662 cd      write (iout,*)
7663 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7664 cd     &   ' and',k,l
7665       eello6_1=0.0d0
7666       eello6_2=0.0d0
7667       eello6_3=0.0d0
7668       eello6_4=0.0d0
7669       eello6_5=0.0d0
7670       eello6_6=0.0d0
7671 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7672 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7673       do iii=1,2
7674         do kkk=1,5
7675           do lll=1,3
7676             derx(lll,kkk,iii)=0.0d0
7677           enddo
7678         enddo
7679       enddo
7680 cd      eij=facont_hb(jj,i)
7681 cd      ekl=facont_hb(kk,k)
7682 cd      ekont=eij*ekl
7683 cd      eij=1.0d0
7684 cd      ekl=1.0d0
7685 cd      ekont=1.0d0
7686       if (l.eq.j+1) then
7687         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7688         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7689         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7690         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7691         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7692         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7693       else
7694         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7695         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7696         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7697         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7698         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7699           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7700         else
7701           eello6_5=0.0d0
7702         endif
7703         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7704       endif
7705 C If turn contributions are considered, they will be handled separately.
7706       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7707 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7708 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7709 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7710 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7711 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7712 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7713 cd      goto 1112
7714       if (j.lt.nres-1) then
7715         j1=j+1
7716         j2=j-1
7717       else
7718         j1=j-1
7719         j2=j-2
7720       endif
7721       if (l.lt.nres-1) then
7722         l1=l+1
7723         l2=l-1
7724       else
7725         l1=l-1
7726         l2=l-2
7727       endif
7728       do ll=1,3
7729 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7730 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7731 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7732 cgrad        ghalf=0.5d0*ggg1(ll)
7733 cd        ghalf=0.0d0
7734         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7735         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7736         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7737         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7738         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7739         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7740         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7741         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7742 cgrad        ghalf=0.5d0*ggg2(ll)
7743 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7744 cd        ghalf=0.0d0
7745         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7746         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7747         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7748         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7749         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7750         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7751       enddo
7752 cd      goto 1112
7753 cgrad      do m=i+1,j-1
7754 cgrad        do ll=1,3
7755 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7756 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7757 cgrad        enddo
7758 cgrad      enddo
7759 cgrad      do m=k+1,l-1
7760 cgrad        do ll=1,3
7761 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7762 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7763 cgrad        enddo
7764 cgrad      enddo
7765 cgrad1112  continue
7766 cgrad      do m=i+2,j2
7767 cgrad        do ll=1,3
7768 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7769 cgrad        enddo
7770 cgrad      enddo
7771 cgrad      do m=k+2,l2
7772 cgrad        do ll=1,3
7773 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7774 cgrad        enddo
7775 cgrad      enddo
7776 cd      do iii=1,nres-3
7777 cd        write (2,*) iii,g_corr6_loc(iii)
7778 cd      enddo
7779       eello6=ekont*eel6
7780 cd      write (2,*) 'ekont',ekont
7781 cd      write (iout,*) 'eello6',ekont*eel6
7782       return
7783       end
7784 c--------------------------------------------------------------------------
7785       double precision function eello6_graph1(i,j,k,l,imat,swap)
7786       implicit real*8 (a-h,o-z)
7787       include 'DIMENSIONS'
7788       include 'COMMON.IOUNITS'
7789       include 'COMMON.CHAIN'
7790       include 'COMMON.DERIV'
7791       include 'COMMON.INTERACT'
7792       include 'COMMON.CONTACTS'
7793       include 'COMMON.TORSION'
7794       include 'COMMON.VAR'
7795       include 'COMMON.GEO'
7796       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7797       logical swap
7798       logical lprn
7799       common /kutas/ lprn
7800 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7801 C
7802 C      Parallel       Antiparallel
7803 C
7804 C          o             o
7805 C         /l\           /j\
7806 C        /   \         /   \
7807 C       /| o |         | o |\
7808 C     \ j|/k\|  /   \  |/k\|l /
7809 C      \ /   \ /     \ /   \ /
7810 C       o     o       o     o
7811 C       i             i
7812 C
7813 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7814       itk=itortyp(itype(k))
7815       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7816       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7817       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7818       call transpose2(EUgC(1,1,k),auxmat(1,1))
7819       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7820       vv1(1)=pizda1(1,1)-pizda1(2,2)
7821       vv1(2)=pizda1(1,2)+pizda1(2,1)
7822       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7823       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7824       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7825       s5=scalar2(vv(1),Dtobr2(1,i))
7826 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7827       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7828       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7829      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7830      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7831      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7832      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7833      & +scalar2(vv(1),Dtobr2der(1,i)))
7834       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7835       vv1(1)=pizda1(1,1)-pizda1(2,2)
7836       vv1(2)=pizda1(1,2)+pizda1(2,1)
7837       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7838       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7839       if (l.eq.j+1) then
7840         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7841      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7842      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7843      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7844      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7845       else
7846         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7847      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7848      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7849      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7850      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7851       endif
7852       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7853       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7854       vv1(1)=pizda1(1,1)-pizda1(2,2)
7855       vv1(2)=pizda1(1,2)+pizda1(2,1)
7856       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7857      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7858      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7859      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7860       do iii=1,2
7861         if (swap) then
7862           ind=3-iii
7863         else
7864           ind=iii
7865         endif
7866         do kkk=1,5
7867           do lll=1,3
7868             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7869             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7870             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7871             call transpose2(EUgC(1,1,k),auxmat(1,1))
7872             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7873      &        pizda1(1,1))
7874             vv1(1)=pizda1(1,1)-pizda1(2,2)
7875             vv1(2)=pizda1(1,2)+pizda1(2,1)
7876             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7877             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7878      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7879             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7880      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7881             s5=scalar2(vv(1),Dtobr2(1,i))
7882             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7883           enddo
7884         enddo
7885       enddo
7886       return
7887       end
7888 c----------------------------------------------------------------------------
7889       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7890       implicit real*8 (a-h,o-z)
7891       include 'DIMENSIONS'
7892       include 'COMMON.IOUNITS'
7893       include 'COMMON.CHAIN'
7894       include 'COMMON.DERIV'
7895       include 'COMMON.INTERACT'
7896       include 'COMMON.CONTACTS'
7897       include 'COMMON.TORSION'
7898       include 'COMMON.VAR'
7899       include 'COMMON.GEO'
7900       logical swap
7901       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7902      & auxvec1(2),auxvec2(1),auxmat1(2,2)
7903       logical lprn
7904       common /kutas/ lprn
7905 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7906 C
7907 C      Parallel       Antiparallel
7908 C
7909 C          o             o
7910 C     \   /l\           /j\   /
7911 C      \ /   \         /   \ /
7912 C       o| o |         | o |o
7913 C     \ j|/k\|      \  |/k\|l
7914 C      \ /   \       \ /   \
7915 C       o             o
7916 C       i             i
7917 C
7918 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7919 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7920 C AL 7/4/01 s1 would occur in the sixth-order moment,
7921 C           but not in a cluster cumulant
7922 #ifdef MOMENT
7923       s1=dip(1,jj,i)*dip(1,kk,k)
7924 #endif
7925       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7926       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7927       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7928       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7929       call transpose2(EUg(1,1,k),auxmat(1,1))
7930       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7931       vv(1)=pizda(1,1)-pizda(2,2)
7932       vv(2)=pizda(1,2)+pizda(2,1)
7933       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7934 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7935 #ifdef MOMENT
7936       eello6_graph2=-(s1+s2+s3+s4)
7937 #else
7938       eello6_graph2=-(s2+s3+s4)
7939 #endif
7940 c      eello6_graph2=-s3
7941 C Derivatives in gamma(i-1)
7942       if (i.gt.1) then
7943 #ifdef MOMENT
7944         s1=dipderg(1,jj,i)*dip(1,kk,k)
7945 #endif
7946         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7947         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7948         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7949         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7950 #ifdef MOMENT
7951         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7952 #else
7953         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7954 #endif
7955 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7956       endif
7957 C Derivatives in gamma(k-1)
7958 #ifdef MOMENT
7959       s1=dip(1,jj,i)*dipderg(1,kk,k)
7960 #endif
7961       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7962       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7963       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7964       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7965       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7966       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7967       vv(1)=pizda(1,1)-pizda(2,2)
7968       vv(2)=pizda(1,2)+pizda(2,1)
7969       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7970 #ifdef MOMENT
7971       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7972 #else
7973       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7974 #endif
7975 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7976 C Derivatives in gamma(j-1) or gamma(l-1)
7977       if (j.gt.1) then
7978 #ifdef MOMENT
7979         s1=dipderg(3,jj,i)*dip(1,kk,k)
7980 #endif
7981         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7982         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7983         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7984         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7985         vv(1)=pizda(1,1)-pizda(2,2)
7986         vv(2)=pizda(1,2)+pizda(2,1)
7987         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7988 #ifdef MOMENT
7989         if (swap) then
7990           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7991         else
7992           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7993         endif
7994 #endif
7995         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7996 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7997       endif
7998 C Derivatives in gamma(l-1) or gamma(j-1)
7999       if (l.gt.1) then
8000 #ifdef MOMENT
8001         s1=dip(1,jj,i)*dipderg(3,kk,k)
8002 #endif
8003         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8004         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8005         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8006         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8007         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8008         vv(1)=pizda(1,1)-pizda(2,2)
8009         vv(2)=pizda(1,2)+pizda(2,1)
8010         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8011 #ifdef MOMENT
8012         if (swap) then
8013           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8014         else
8015           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8016         endif
8017 #endif
8018         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8019 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8020       endif
8021 C Cartesian derivatives.
8022       if (lprn) then
8023         write (2,*) 'In eello6_graph2'
8024         do iii=1,2
8025           write (2,*) 'iii=',iii
8026           do kkk=1,5
8027             write (2,*) 'kkk=',kkk
8028             do jjj=1,2
8029               write (2,'(3(2f10.5),5x)')
8030      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8031             enddo
8032           enddo
8033         enddo
8034       endif
8035       do iii=1,2
8036         do kkk=1,5
8037           do lll=1,3
8038 #ifdef MOMENT
8039             if (iii.eq.1) then
8040               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8041             else
8042               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8043             endif
8044 #endif
8045             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8046      &        auxvec(1))
8047             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8048             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8049      &        auxvec(1))
8050             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8051             call transpose2(EUg(1,1,k),auxmat(1,1))
8052             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8053      &        pizda(1,1))
8054             vv(1)=pizda(1,1)-pizda(2,2)
8055             vv(2)=pizda(1,2)+pizda(2,1)
8056             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8057 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8058 #ifdef MOMENT
8059             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8060 #else
8061             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8062 #endif
8063             if (swap) then
8064               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8065             else
8066               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8067             endif
8068           enddo
8069         enddo
8070       enddo
8071       return
8072       end
8073 c----------------------------------------------------------------------------
8074       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8075       implicit real*8 (a-h,o-z)
8076       include 'DIMENSIONS'
8077       include 'COMMON.IOUNITS'
8078       include 'COMMON.CHAIN'
8079       include 'COMMON.DERIV'
8080       include 'COMMON.INTERACT'
8081       include 'COMMON.CONTACTS'
8082       include 'COMMON.TORSION'
8083       include 'COMMON.VAR'
8084       include 'COMMON.GEO'
8085       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8086       logical swap
8087 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8088 C
8089 C      Parallel       Antiparallel
8090 C
8091 C          o             o
8092 C         /l\   /   \   /j\
8093 C        /   \ /     \ /   \
8094 C       /| o |o       o| o |\
8095 C       j|/k\|  /      |/k\|l /
8096 C        /   \ /       /   \ /
8097 C       /     o       /     o
8098 C       i             i
8099 C
8100 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8101 C
8102 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8103 C           energy moment and not to the cluster cumulant.
8104       iti=itortyp(itype(i))
8105       if (j.lt.nres-1) then
8106         itj1=itortyp(itype(j+1))
8107       else
8108         itj1=ntortyp+1
8109       endif
8110       itk=itortyp(itype(k))
8111       itk1=itortyp(itype(k+1))
8112       if (l.lt.nres-1) then
8113         itl1=itortyp(itype(l+1))
8114       else
8115         itl1=ntortyp+1
8116       endif
8117 #ifdef MOMENT
8118       s1=dip(4,jj,i)*dip(4,kk,k)
8119 #endif
8120       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8121       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8122       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8123       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8124       call transpose2(EE(1,1,itk),auxmat(1,1))
8125       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8126       vv(1)=pizda(1,1)+pizda(2,2)
8127       vv(2)=pizda(2,1)-pizda(1,2)
8128       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8129 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8130 cd     & "sum",-(s2+s3+s4)
8131 #ifdef MOMENT
8132       eello6_graph3=-(s1+s2+s3+s4)
8133 #else
8134       eello6_graph3=-(s2+s3+s4)
8135 #endif
8136 c      eello6_graph3=-s4
8137 C Derivatives in gamma(k-1)
8138       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8139       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8140       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8141       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8142 C Derivatives in gamma(l-1)
8143       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8144       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8145       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8146       vv(1)=pizda(1,1)+pizda(2,2)
8147       vv(2)=pizda(2,1)-pizda(1,2)
8148       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8149       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8150 C Cartesian derivatives.
8151       do iii=1,2
8152         do kkk=1,5
8153           do lll=1,3
8154 #ifdef MOMENT
8155             if (iii.eq.1) then
8156               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8157             else
8158               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8159             endif
8160 #endif
8161             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8162      &        auxvec(1))
8163             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8164             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8165      &        auxvec(1))
8166             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8167             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8168      &        pizda(1,1))
8169             vv(1)=pizda(1,1)+pizda(2,2)
8170             vv(2)=pizda(2,1)-pizda(1,2)
8171             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8172 #ifdef MOMENT
8173             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8174 #else
8175             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8176 #endif
8177             if (swap) then
8178               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8179             else
8180               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8181             endif
8182 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8183           enddo
8184         enddo
8185       enddo
8186       return
8187       end
8188 c----------------------------------------------------------------------------
8189       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8190       implicit real*8 (a-h,o-z)
8191       include 'DIMENSIONS'
8192       include 'COMMON.IOUNITS'
8193       include 'COMMON.CHAIN'
8194       include 'COMMON.DERIV'
8195       include 'COMMON.INTERACT'
8196       include 'COMMON.CONTACTS'
8197       include 'COMMON.TORSION'
8198       include 'COMMON.VAR'
8199       include 'COMMON.GEO'
8200       include 'COMMON.FFIELD'
8201       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8202      & auxvec1(2),auxmat1(2,2)
8203       logical swap
8204 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8205 C
8206 C      Parallel       Antiparallel
8207 C
8208 C          o             o
8209 C         /l\   /   \   /j\
8210 C        /   \ /     \ /   \
8211 C       /| o |o       o| o |\
8212 C     \ j|/k\|      \  |/k\|l
8213 C      \ /   \       \ /   \
8214 C       o     \       o     \
8215 C       i             i
8216 C
8217 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8218 C
8219 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8220 C           energy moment and not to the cluster cumulant.
8221 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8222       iti=itortyp(itype(i))
8223       itj=itortyp(itype(j))
8224       if (j.lt.nres-1) then
8225         itj1=itortyp(itype(j+1))
8226       else
8227         itj1=ntortyp+1
8228       endif
8229       itk=itortyp(itype(k))
8230       if (k.lt.nres-1) then
8231         itk1=itortyp(itype(k+1))
8232       else
8233         itk1=ntortyp+1
8234       endif
8235       itl=itortyp(itype(l))
8236       if (l.lt.nres-1) then
8237         itl1=itortyp(itype(l+1))
8238       else
8239         itl1=ntortyp+1
8240       endif
8241 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8242 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8243 cd     & ' itl',itl,' itl1',itl1
8244 #ifdef MOMENT
8245       if (imat.eq.1) then
8246         s1=dip(3,jj,i)*dip(3,kk,k)
8247       else
8248         s1=dip(2,jj,j)*dip(2,kk,l)
8249       endif
8250 #endif
8251       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8252       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8253       if (j.eq.l+1) then
8254         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8255         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8256       else
8257         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8258         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8259       endif
8260       call transpose2(EUg(1,1,k),auxmat(1,1))
8261       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8262       vv(1)=pizda(1,1)-pizda(2,2)
8263       vv(2)=pizda(2,1)+pizda(1,2)
8264       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8265 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8266 #ifdef MOMENT
8267       eello6_graph4=-(s1+s2+s3+s4)
8268 #else
8269       eello6_graph4=-(s2+s3+s4)
8270 #endif
8271 C Derivatives in gamma(i-1)
8272       if (i.gt.1) then
8273 #ifdef MOMENT
8274         if (imat.eq.1) then
8275           s1=dipderg(2,jj,i)*dip(3,kk,k)
8276         else
8277           s1=dipderg(4,jj,j)*dip(2,kk,l)
8278         endif
8279 #endif
8280         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8281         if (j.eq.l+1) then
8282           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8283           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8284         else
8285           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8286           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8287         endif
8288         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8289         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8290 cd          write (2,*) 'turn6 derivatives'
8291 #ifdef MOMENT
8292           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8293 #else
8294           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8295 #endif
8296         else
8297 #ifdef MOMENT
8298           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8299 #else
8300           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8301 #endif
8302         endif
8303       endif
8304 C Derivatives in gamma(k-1)
8305 #ifdef MOMENT
8306       if (imat.eq.1) then
8307         s1=dip(3,jj,i)*dipderg(2,kk,k)
8308       else
8309         s1=dip(2,jj,j)*dipderg(4,kk,l)
8310       endif
8311 #endif
8312       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8313       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8314       if (j.eq.l+1) then
8315         call matvec2(ADtEA1derg(1,1,2,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,2,3-imat),b1(1,itl1),auxvec1(1))
8319         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8320       endif
8321       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8322       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8323       vv(1)=pizda(1,1)-pizda(2,2)
8324       vv(2)=pizda(2,1)+pizda(1,2)
8325       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8326       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8327 #ifdef MOMENT
8328         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8329 #else
8330         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8331 #endif
8332       else
8333 #ifdef MOMENT
8334         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8335 #else
8336         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8337 #endif
8338       endif
8339 C Derivatives in gamma(j-1) or gamma(l-1)
8340       if (l.eq.j+1 .and. l.gt.1) then
8341         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8342         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8343         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8344         vv(1)=pizda(1,1)-pizda(2,2)
8345         vv(2)=pizda(2,1)+pizda(1,2)
8346         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8347         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8348       else if (j.gt.1) then
8349         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8350         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8351         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8352         vv(1)=pizda(1,1)-pizda(2,2)
8353         vv(2)=pizda(2,1)+pizda(1,2)
8354         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8355         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8356           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8357         else
8358           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8359         endif
8360       endif
8361 C Cartesian derivatives.
8362       do iii=1,2
8363         do kkk=1,5
8364           do lll=1,3
8365 #ifdef MOMENT
8366             if (iii.eq.1) then
8367               if (imat.eq.1) then
8368                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8369               else
8370                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8371               endif
8372             else
8373               if (imat.eq.1) then
8374                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8375               else
8376                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8377               endif
8378             endif
8379 #endif
8380             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8381      &        auxvec(1))
8382             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8383             if (j.eq.l+1) then
8384               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8385      &          b1(1,itj1),auxvec(1))
8386               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8387             else
8388               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8389      &          b1(1,itl1),auxvec(1))
8390               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8391             endif
8392             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8393      &        pizda(1,1))
8394             vv(1)=pizda(1,1)-pizda(2,2)
8395             vv(2)=pizda(2,1)+pizda(1,2)
8396             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8397             if (swap) then
8398               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8399 #ifdef MOMENT
8400                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8401      &             -(s1+s2+s4)
8402 #else
8403                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8404      &             -(s2+s4)
8405 #endif
8406                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8407               else
8408 #ifdef MOMENT
8409                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8410 #else
8411                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8412 #endif
8413                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8414               endif
8415             else
8416 #ifdef MOMENT
8417               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8418 #else
8419               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8420 #endif
8421               if (l.eq.j+1) then
8422                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8423               else
8424                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8425               endif
8426             endif
8427           enddo
8428         enddo
8429       enddo
8430       return
8431       end
8432 c----------------------------------------------------------------------------
8433       double precision function eello_turn6(i,jj,kk)
8434       implicit real*8 (a-h,o-z)
8435       include 'DIMENSIONS'
8436       include 'COMMON.IOUNITS'
8437       include 'COMMON.CHAIN'
8438       include 'COMMON.DERIV'
8439       include 'COMMON.INTERACT'
8440       include 'COMMON.CONTACTS'
8441       include 'COMMON.TORSION'
8442       include 'COMMON.VAR'
8443       include 'COMMON.GEO'
8444       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8445      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8446      &  ggg1(3),ggg2(3)
8447       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8448      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8449 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8450 C           the respective energy moment and not to the cluster cumulant.
8451       s1=0.0d0
8452       s8=0.0d0
8453       s13=0.0d0
8454 c
8455       eello_turn6=0.0d0
8456       j=i+4
8457       k=i+1
8458       l=i+3
8459       iti=itortyp(itype(i))
8460       itk=itortyp(itype(k))
8461       itk1=itortyp(itype(k+1))
8462       itl=itortyp(itype(l))
8463       itj=itortyp(itype(j))
8464 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8465 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8466 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8467 cd        eello6=0.0d0
8468 cd        return
8469 cd      endif
8470 cd      write (iout,*)
8471 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8472 cd     &   ' and',k,l
8473 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8474       do iii=1,2
8475         do kkk=1,5
8476           do lll=1,3
8477             derx_turn(lll,kkk,iii)=0.0d0
8478           enddo
8479         enddo
8480       enddo
8481 cd      eij=1.0d0
8482 cd      ekl=1.0d0
8483 cd      ekont=1.0d0
8484       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8485 cd      eello6_5=0.0d0
8486 cd      write (2,*) 'eello6_5',eello6_5
8487 #ifdef MOMENT
8488       call transpose2(AEA(1,1,1),auxmat(1,1))
8489       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8490       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8491       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8492 #endif
8493       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8494       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8495       s2 = scalar2(b1(1,itk),vtemp1(1))
8496 #ifdef MOMENT
8497       call transpose2(AEA(1,1,2),atemp(1,1))
8498       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8499       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8500       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8501 #endif
8502       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8503       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8504       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8505 #ifdef MOMENT
8506       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8507       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8508       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8509       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8510       ss13 = scalar2(b1(1,itk),vtemp4(1))
8511       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8512 #endif
8513 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8514 c      s1=0.0d0
8515 c      s2=0.0d0
8516 c      s8=0.0d0
8517 c      s12=0.0d0
8518 c      s13=0.0d0
8519       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8520 C Derivatives in gamma(i+2)
8521       s1d =0.0d0
8522       s8d =0.0d0
8523 #ifdef MOMENT
8524       call transpose2(AEA(1,1,1),auxmatd(1,1))
8525       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8526       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8527       call transpose2(AEAderg(1,1,2),atempd(1,1))
8528       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8529       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8530 #endif
8531       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8532       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8533       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8534 c      s1d=0.0d0
8535 c      s2d=0.0d0
8536 c      s8d=0.0d0
8537 c      s12d=0.0d0
8538 c      s13d=0.0d0
8539       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8540 C Derivatives in gamma(i+3)
8541 #ifdef MOMENT
8542       call transpose2(AEA(1,1,1),auxmatd(1,1))
8543       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8544       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8545       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8546 #endif
8547       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8548       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8549       s2d = scalar2(b1(1,itk),vtemp1d(1))
8550 #ifdef MOMENT
8551       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8552       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8553 #endif
8554       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8555 #ifdef MOMENT
8556       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8557       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8558       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8559 #endif
8560 c      s1d=0.0d0
8561 c      s2d=0.0d0
8562 c      s8d=0.0d0
8563 c      s12d=0.0d0
8564 c      s13d=0.0d0
8565 #ifdef MOMENT
8566       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8567      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8568 #else
8569       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8570      &               -0.5d0*ekont*(s2d+s12d)
8571 #endif
8572 C Derivatives in gamma(i+4)
8573       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8574       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8575       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8576 #ifdef MOMENT
8577       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8578       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8579       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8580 #endif
8581 c      s1d=0.0d0
8582 c      s2d=0.0d0
8583 c      s8d=0.0d0
8584 C      s12d=0.0d0
8585 c      s13d=0.0d0
8586 #ifdef MOMENT
8587       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8588 #else
8589       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8590 #endif
8591 C Derivatives in gamma(i+5)
8592 #ifdef MOMENT
8593       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8594       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8595       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8596 #endif
8597       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8598       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8599       s2d = scalar2(b1(1,itk),vtemp1d(1))
8600 #ifdef MOMENT
8601       call transpose2(AEA(1,1,2),atempd(1,1))
8602       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8603       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8604 #endif
8605       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8606       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8607 #ifdef MOMENT
8608       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8609       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8610       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8611 #endif
8612 c      s1d=0.0d0
8613 c      s2d=0.0d0
8614 c      s8d=0.0d0
8615 c      s12d=0.0d0
8616 c      s13d=0.0d0
8617 #ifdef MOMENT
8618       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8619      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8620 #else
8621       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8622      &               -0.5d0*ekont*(s2d+s12d)
8623 #endif
8624 C Cartesian derivatives
8625       do iii=1,2
8626         do kkk=1,5
8627           do lll=1,3
8628 #ifdef MOMENT
8629             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8630             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8631             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8632 #endif
8633             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8634             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8635      &          vtemp1d(1))
8636             s2d = scalar2(b1(1,itk),vtemp1d(1))
8637 #ifdef MOMENT
8638             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8639             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8640             s8d = -(atempd(1,1)+atempd(2,2))*
8641      &           scalar2(cc(1,1,itl),vtemp2(1))
8642 #endif
8643             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8644      &           auxmatd(1,1))
8645             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8646             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8647 c      s1d=0.0d0
8648 c      s2d=0.0d0
8649 c      s8d=0.0d0
8650 c      s12d=0.0d0
8651 c      s13d=0.0d0
8652 #ifdef MOMENT
8653             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8654      &        - 0.5d0*(s1d+s2d)
8655 #else
8656             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8657      &        - 0.5d0*s2d
8658 #endif
8659 #ifdef MOMENT
8660             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8661      &        - 0.5d0*(s8d+s12d)
8662 #else
8663             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8664      &        - 0.5d0*s12d
8665 #endif
8666           enddo
8667         enddo
8668       enddo
8669 #ifdef MOMENT
8670       do kkk=1,5
8671         do lll=1,3
8672           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8673      &      achuj_tempd(1,1))
8674           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8675           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8676           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8677           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8678           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8679      &      vtemp4d(1))
8680           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8681           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8682           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8683         enddo
8684       enddo
8685 #endif
8686 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8687 cd     &  16*eel_turn6_num
8688 cd      goto 1112
8689       if (j.lt.nres-1) then
8690         j1=j+1
8691         j2=j-1
8692       else
8693         j1=j-1
8694         j2=j-2
8695       endif
8696       if (l.lt.nres-1) then
8697         l1=l+1
8698         l2=l-1
8699       else
8700         l1=l-1
8701         l2=l-2
8702       endif
8703       do ll=1,3
8704 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8705 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8706 cgrad        ghalf=0.5d0*ggg1(ll)
8707 cd        ghalf=0.0d0
8708         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8709         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8710         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8711      &    +ekont*derx_turn(ll,2,1)
8712         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8713         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8714      &    +ekont*derx_turn(ll,4,1)
8715         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8716         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8717         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8718 cgrad        ghalf=0.5d0*ggg2(ll)
8719 cd        ghalf=0.0d0
8720         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8721      &    +ekont*derx_turn(ll,2,2)
8722         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8723         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8724      &    +ekont*derx_turn(ll,4,2)
8725         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8726         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8727         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8728       enddo
8729 cd      goto 1112
8730 cgrad      do m=i+1,j-1
8731 cgrad        do ll=1,3
8732 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8733 cgrad        enddo
8734 cgrad      enddo
8735 cgrad      do m=k+1,l-1
8736 cgrad        do ll=1,3
8737 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8738 cgrad        enddo
8739 cgrad      enddo
8740 cgrad1112  continue
8741 cgrad      do m=i+2,j2
8742 cgrad        do ll=1,3
8743 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8744 cgrad        enddo
8745 cgrad      enddo
8746 cgrad      do m=k+2,l2
8747 cgrad        do ll=1,3
8748 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8749 cgrad        enddo
8750 cgrad      enddo
8751 cd      do iii=1,nres-3
8752 cd        write (2,*) iii,g_corr6_loc(iii)
8753 cd      enddo
8754       eello_turn6=ekont*eel_turn6
8755 cd      write (2,*) 'ekont',ekont
8756 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8757       return
8758       end
8759
8760 C-----------------------------------------------------------------------------
8761       double precision function scalar(u,v)
8762 !DIR$ INLINEALWAYS scalar
8763 #ifndef OSF
8764 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8765 #endif
8766       implicit none
8767       double precision u(3),v(3)
8768 cd      double precision sc
8769 cd      integer i
8770 cd      sc=0.0d0
8771 cd      do i=1,3
8772 cd        sc=sc+u(i)*v(i)
8773 cd      enddo
8774 cd      scalar=sc
8775
8776       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8777       return
8778       end
8779 crc-------------------------------------------------
8780       SUBROUTINE MATVEC2(A1,V1,V2)
8781 !DIR$ INLINEALWAYS MATVEC2
8782 #ifndef OSF
8783 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8784 #endif
8785       implicit real*8 (a-h,o-z)
8786       include 'DIMENSIONS'
8787       DIMENSION A1(2,2),V1(2),V2(2)
8788 c      DO 1 I=1,2
8789 c        VI=0.0
8790 c        DO 3 K=1,2
8791 c    3     VI=VI+A1(I,K)*V1(K)
8792 c        Vaux(I)=VI
8793 c    1 CONTINUE
8794
8795       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8796       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8797
8798       v2(1)=vaux1
8799       v2(2)=vaux2
8800       END
8801 C---------------------------------------
8802       SUBROUTINE MATMAT2(A1,A2,A3)
8803 #ifndef OSF
8804 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8805 #endif
8806       implicit real*8 (a-h,o-z)
8807       include 'DIMENSIONS'
8808       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8809 c      DIMENSION AI3(2,2)
8810 c        DO  J=1,2
8811 c          A3IJ=0.0
8812 c          DO K=1,2
8813 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8814 c          enddo
8815 c          A3(I,J)=A3IJ
8816 c       enddo
8817 c      enddo
8818
8819       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8820       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8821       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8822       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8823
8824       A3(1,1)=AI3_11
8825       A3(2,1)=AI3_21
8826       A3(1,2)=AI3_12
8827       A3(2,2)=AI3_22
8828       END
8829
8830 c-------------------------------------------------------------------------
8831       double precision function scalar2(u,v)
8832 !DIR$ INLINEALWAYS scalar2
8833       implicit none
8834       double precision u(2),v(2)
8835       double precision sc
8836       integer i
8837       scalar2=u(1)*v(1)+u(2)*v(2)
8838       return
8839       end
8840
8841 C-----------------------------------------------------------------------------
8842
8843       subroutine transpose2(a,at)
8844 !DIR$ INLINEALWAYS transpose2
8845 #ifndef OSF
8846 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8847 #endif
8848       implicit none
8849       double precision a(2,2),at(2,2)
8850       at(1,1)=a(1,1)
8851       at(1,2)=a(2,1)
8852       at(2,1)=a(1,2)
8853       at(2,2)=a(2,2)
8854       return
8855       end
8856 c--------------------------------------------------------------------------
8857       subroutine transpose(n,a,at)
8858       implicit none
8859       integer n,i,j
8860       double precision a(n,n),at(n,n)
8861       do i=1,n
8862         do j=1,n
8863           at(j,i)=a(i,j)
8864         enddo
8865       enddo
8866       return
8867       end
8868 C---------------------------------------------------------------------------
8869       subroutine prodmat3(a1,a2,kk,transp,prod)
8870 !DIR$ INLINEALWAYS prodmat3
8871 #ifndef OSF
8872 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8873 #endif
8874       implicit none
8875       integer i,j
8876       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8877       logical transp
8878 crc      double precision auxmat(2,2),prod_(2,2)
8879
8880       if (transp) then
8881 crc        call transpose2(kk(1,1),auxmat(1,1))
8882 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8883 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8884
8885            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8886      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8887            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8888      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8889            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8890      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8891            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8892      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8893
8894       else
8895 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8896 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8897
8898            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8899      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8900            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8901      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8902            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8903      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8904            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8905      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8906
8907       endif
8908 c      call transpose2(a2(1,1),a2t(1,1))
8909
8910 crc      print *,transp
8911 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8912 crc      print *,((prod(i,j),i=1,2),j=1,2)
8913
8914       return
8915       end
8916