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

   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+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+wcorr*ecorr+wcorr5*ecorr5
 398      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 399      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 400      & +wbond*estr+Uconst+wsccor*esccor
 401 #endif
 402       energia(0)=etot
 403 c detecting NaNQ
 404 #ifdef ISNAN
 405 #ifdef AIX
 406       if (isnan(etot).ne.0) energia(0)=1.0d+99
 407 #else
 408       if (isnan(etot)) energia(0)=1.0d+99
 409 #endif
 410 #else
 411       i=0
 412 #ifdef WINPGI
 413       idumm=proc_proc(etot,i)
 414 #else
 415       call proc_proc(etot,i)
 416 #endif
 417       if(i.eq.1)energia(0)=1.0d+99
 418 #endif
 419 #ifdef MPI
 420       endif
 421 #endif
 422       return
 423       end
 424 c-------------------------------------------------------------------------------
 425       subroutine sum_gradient
 426       implicit real*8 (a-h,o-z)
 427       include 'DIMENSIONS'
 428 #ifndef ISNAN
 429       external proc_proc
 430 #ifdef WINPGI
 431 cMS$ATTRIBUTES C ::  proc_proc
 432 #endif
 433 #endif
 434 #ifdef MPI
 435       include 'mpif.h'
 436       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 437      &  glocbuf(4*maxres),gradbufc_sum(3,maxres)
 438 #endif
 439       include 'COMMON.SETUP'
 440       include 'COMMON.IOUNITS'
 441       include 'COMMON.FFIELD'
 442       include 'COMMON.DERIV'
 443       include 'COMMON.INTERACT'
 444       include 'COMMON.SBRIDGE'
 445       include 'COMMON.CHAIN'
 446       include 'COMMON.VAR'
 447       include 'COMMON.CONTROL'
 448       include 'COMMON.TIME1'
 449       include 'COMMON.MAXGRAD'
 450 #ifdef TIMING
 451       time01=MPI_Wtime()
 452 #endif
 453 #ifdef DEBUG
 454       write (iout,*) "sum_gradient gvdwc, gvdwx"
 455       do i=1,nres
 456         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 457      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 458       enddo
 459       call flush(iout)
 460 #endif
 461 #ifdef MPI
 462 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 463         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 464      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 465 #endif
 466 C
 467 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 468 C            in virtual-bond-vector coordinates
 469 C
 470 #ifdef DEBUG
 471 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 472 c      do i=1,nres-1
 473 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 474 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 475 c      enddo
 476 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 477 c      do i=1,nres-1
 478 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 479 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 480 c      enddo
 481       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 482       do i=1,nres
 483         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 484      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 485      &   g_corr5_loc(i)
 486       enddo
 487       call flush(iout)
 488 #endif
 489 #ifdef SPLITELE
 490       do i=1,nct
 491         do j=1,3
 492           gradbufc(j,i)=wsc*gvdwc(j,i)+
 493      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 494      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 495      &                wel_loc*gel_loc_long(j,i)+
 496      &                wcorr*gradcorr_long(j,i)+
 497      &                wcorr5*gradcorr5_long(j,i)+
 498      &                wcorr6*gradcorr6_long(j,i)+
 499      &                wturn6*gcorr6_turn_long(j,i)+
 500      &                wstrain*ghpbc(j,i)
 501         enddo
 502       enddo
 503 #else
 504       do i=1,nct
 505         do j=1,3
 506           gradbufc(j,i)=wsc*gvdwc(j,i)+
 507      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 508      &                welec*gelc_long(j,i)+
 509      &                wbond*gradb(j,i)+
 510      &                wel_loc*gel_loc_long(j,i)+
 511      &                wcorr*gradcorr_long(j,i)+
 512      &                wcorr5*gradcorr5_long(j,i)+
 513      &                wcorr6*gradcorr6_long(j,i)+
 514      &                wturn6*gcorr6_turn_long(j,i)+
 515      &                wstrain*ghpbc(j,i)
 516         enddo
 517       enddo
 518 #endif
 519 #ifdef MPI
 520       if (nfgtasks.gt.1) then
 521       time00=MPI_Wtime()
 522 #ifdef DEBUG
 523       write (iout,*) "gradbufc before allreduce"
 524       do i=1,nres
 525         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 526       enddo
 527       call flush(iout)
 528 #endif
 529       do i=1,nres
 530         do j=1,3
 531           gradbufc_sum(j,i)=gradbufc(j,i)
 532         enddo
 533       enddo
 534 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 535 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 536 c      time_reduce=time_reduce+MPI_Wtime()-time00
 537 #ifdef DEBUG
 538 c      write (iout,*) "gradbufc_sum after allreduce"
 539 c      do i=1,nres
 540 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 541 c      enddo
 542 c      call flush(iout)
 543 #endif
 544 #ifdef TIMING
 545 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 546 #endif
 547       do i=nnt,nres
 548         do k=1,3
 549           gradbufc(k,i)=0.0d0
 550         enddo
 551       enddo
 552 #ifdef DEBUG
 553       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 554       write (iout,*) (i," jgrad_start",jgrad_start(i),
 555      &                  " jgrad_end  ",jgrad_end(i),
 556      &                  i=igrad_start,igrad_end)
 557 #endif
 558 c
 559 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 560 c do not parallelize this part.
 561 c
 562 c      do i=igrad_start,igrad_end
 563 c        do j=jgrad_start(i),jgrad_end(i)
 564 c          do k=1,3
 565 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 566 c          enddo
 567 c        enddo
 568 c      enddo
 569       do j=1,3
 570         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 571       enddo
 572       do i=nres-2,nnt,-1
 573         do j=1,3
 574           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 575         enddo
 576       enddo
 577 #ifdef DEBUG
 578       write (iout,*) "gradbufc after summing"
 579       do i=1,nres
 580         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 581       enddo
 582       call flush(iout)
 583 #endif
 584       else
 585 #endif
 586 #ifdef DEBUG
 587       write (iout,*) "gradbufc"
 588       do i=1,nres
 589         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 590       enddo
 591       call flush(iout)
 592 #endif
 593       do i=1,nres
 594         do j=1,3
 595           gradbufc_sum(j,i)=gradbufc(j,i)
 596           gradbufc(j,i)=0.0d0
 597         enddo
 598       enddo
 599       do j=1,3
 600         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 601       enddo
 602       do i=nres-2,nnt,-1
 603         do j=1,3
 604           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 605         enddo
 606       enddo
 607 c      do i=nnt,nres-1
 608 c        do k=1,3
 609 c          gradbufc(k,i)=0.0d0
 610 c        enddo
 611 c        do j=i+1,nres
 612 c          do k=1,3
 613 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 614 c          enddo
 615 c        enddo
 616 c      enddo
 617 #ifdef DEBUG
 618       write (iout,*) "gradbufc after summing"
 619       do i=1,nres
 620         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 621       enddo
 622       call flush(iout)
 623 #endif
 624 #ifdef MPI
 625       endif
 626 #endif
 627       do k=1,3
 628         gradbufc(k,nres)=0.0d0
 629       enddo
 630       do i=1,nct
 631         do j=1,3
 632 #ifdef SPLITELE
 633           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 634      &                wel_loc*gel_loc(j,i)+
 635      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 636      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 637      &                wel_loc*gel_loc_long(j,i)+
 638      &                wcorr*gradcorr_long(j,i)+
 639      &                wcorr5*gradcorr5_long(j,i)+
 640      &                wcorr6*gradcorr6_long(j,i)+
 641      &                wturn6*gcorr6_turn_long(j,i))+
 642      &                wbond*gradb(j,i)+
 643      &                wcorr*gradcorr(j,i)+
 644      &                wturn3*gcorr3_turn(j,i)+
 645      &                wturn4*gcorr4_turn(j,i)+
 646      &                wcorr5*gradcorr5(j,i)+
 647      &                wcorr6*gradcorr6(j,i)+
 648      &                wturn6*gcorr6_turn(j,i)+
 649      &                wsccor*gsccorc(j,i)
 650      &               +wscloc*gscloc(j,i)
 651 #else
 652           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 653      &                wel_loc*gel_loc(j,i)+
 654      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 655      &                welec*gelc_long(j,i)
 656      &                wel_loc*gel_loc_long(j,i)+
 657      &                wcorr*gcorr_long(j,i)+
 658      &                wcorr5*gradcorr5_long(j,i)+
 659      &                wcorr6*gradcorr6_long(j,i)+
 660      &                wturn6*gcorr6_turn_long(j,i))+
 661      &                wbond*gradb(j,i)+
 662      &                wcorr*gradcorr(j,i)+
 663      &                wturn3*gcorr3_turn(j,i)+
 664      &                wturn4*gcorr4_turn(j,i)+
 665      &                wcorr5*gradcorr5(j,i)+
 666      &                wcorr6*gradcorr6(j,i)+
 667      &                wturn6*gcorr6_turn(j,i)+
 668      &                wsccor*gsccorc(j,i)
 669      &               +wscloc*gscloc(j,i)
 670 #endif
 671           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 672      &                  wbond*gradbx(j,i)+
 673      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 674      &                  wsccor*gsccorx(j,i)
 675      &                 +wscloc*gsclocx(j,i)
 676         enddo
 677       enddo
 678 #ifdef DEBUG
 679       write (iout,*) "gloc before adding corr"
 680       do i=1,4*nres
 681         write (iout,*) i,gloc(i,icg)
 682       enddo
 683 #endif
 684       do i=1,nres-3
 685         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 686      &   +wcorr5*g_corr5_loc(i)
 687      &   +wcorr6*g_corr6_loc(i)
 688      &   +wturn4*gel_loc_turn4(i)
 689      &   +wturn3*gel_loc_turn3(i)
 690      &   +wturn6*gel_loc_turn6(i)
 691      &   +wel_loc*gel_loc_loc(i)
 692      &   +wsccor*gsccor_loc(i)
 693       enddo
 694 #ifdef DEBUG
 695       write (iout,*) "gloc after adding corr"
 696       do i=1,4*nres
 697         write (iout,*) i,gloc(i,icg)
 698       enddo
 699 #endif
 700 #ifdef MPI
 701       if (nfgtasks.gt.1) then
 702         do j=1,3
 703           do i=1,nres
 704             gradbufc(j,i)=gradc(j,i,icg)
 705             gradbufx(j,i)=gradx(j,i,icg)
 706           enddo
 707         enddo
 708         do i=1,4*nres
 709           glocbuf(i)=gloc(i,icg)
 710         enddo
 711         time00=MPI_Wtime()
 712         call MPI_Barrier(FG_COMM,IERR)
 713         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 714         time00=MPI_Wtime()
 715         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 716      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 717         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 718      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 719         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 720      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 721         time_reduce=time_reduce+MPI_Wtime()-time00
 722 #ifdef DEBUG
 723       write (iout,*) "gloc after reduce"
 724       do i=1,4*nres
 725         write (iout,*) i,gloc(i,icg)
 726       enddo
 727 #endif
 728       endif
 729 #endif
 730       if (gnorm_check) then
 731 c
 732 c Compute the maximum elements of the gradient
 733 c
 734       gvdwc_max=0.0d0
 735       gvdwc_scp_max=0.0d0
 736       gelc_max=0.0d0
 737       gvdwpp_max=0.0d0
 738       gradb_max=0.0d0
 739       ghpbc_max=0.0d0
 740       gradcorr_max=0.0d0
 741       gel_loc_max=0.0d0
 742       gcorr3_turn_max=0.0d0
 743       gcorr4_turn_max=0.0d0
 744       gradcorr5_max=0.0d0
 745       gradcorr6_max=0.0d0
 746       gcorr6_turn_max=0.0d0
 747       gsccorc_max=0.0d0
 748       gscloc_max=0.0d0
 749       gvdwx_max=0.0d0
 750       gradx_scp_max=0.0d0
 751       ghpbx_max=0.0d0
 752       gradxorr_max=0.0d0
 753       gsccorx_max=0.0d0
 754       gsclocx_max=0.0d0
 755       do i=1,nct
 756         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 757         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 758         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 759         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 760      &   gvdwc_scp_max=gvdwc_scp_norm
 761         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 762         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 763         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 764         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 765         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 766         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 767         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 768         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 769         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 770         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 771         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 772         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 773         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 774      &    gcorr3_turn(1,i)))
 775         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 776      &    gcorr3_turn_max=gcorr3_turn_norm
 777         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 778      &    gcorr4_turn(1,i)))
 779         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 780      &    gcorr4_turn_max=gcorr4_turn_norm
 781         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 782         if (gradcorr5_norm.gt.gradcorr5_max)
 783      &    gradcorr5_max=gradcorr5_norm
 784         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 785         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 786         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 787      &    gcorr6_turn(1,i)))
 788         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 789      &    gcorr6_turn_max=gcorr6_turn_norm
 790         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 791         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 792         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 793         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 794         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 795         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 796         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 797         if (gradx_scp_norm.gt.gradx_scp_max)
 798      &    gradx_scp_max=gradx_scp_norm
 799         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 800         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 801         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 802         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 803         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 804         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 805         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 806         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 807       enddo
 808       if (gradout) then
 809 #ifdef AIX
 810         open(istat,file=statname,position="append")
 811 #else
 812         open(istat,file=statname,access="append")
 813 #endif
 814         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 815      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 816      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 817      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 818      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 819      &     gsccorx_max,gsclocx_max
 820         close(istat)
 821         if (gvdwc_max.gt.1.0d4) then
 822           write (iout,*) "gvdwc gvdwx gradb gradbx"
 823           do i=nnt,nct
 824             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 825      &        gradb(j,i),gradbx(j,i),j=1,3)
 826           enddo
 827           call pdbout(0.0d0,'cipiszcze',iout)
 828           call flush(iout)
 829         endif
 830       endif
 831       endif
 832 #ifdef DEBUG
 833       write (iout,*) "gradc gradx gloc"
 834       do i=1,nres
 835         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 836      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 837       enddo
 838 #endif
 839 #ifdef TIMING
 840       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 841 #endif
 842       return
 843       end
 844 c-------------------------------------------------------------------------------
 845       subroutine rescale_weights(t_bath)
 846       implicit real*8 (a-h,o-z)
 847       include 'DIMENSIONS'
 848       include 'COMMON.IOUNITS'
 849       include 'COMMON.FFIELD'
 850       include 'COMMON.SBRIDGE'
 851       double precision kfac /2.4d0/
 852       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 853 c      facT=temp0/t_bath
 854 c      facT=2*temp0/(t_bath+temp0)
 855       if (rescale_mode.eq.0) then
 856         facT=1.0d0
 857         facT2=1.0d0
 858         facT3=1.0d0
 859         facT4=1.0d0
 860         facT5=1.0d0
 861       else if (rescale_mode.eq.1) then
 862         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 863         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 864         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 865         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 866         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 867       else if (rescale_mode.eq.2) then
 868         x=t_bath/temp0
 869         x2=x*x
 870         x3=x2*x
 871         x4=x3*x
 872         x5=x4*x
 873         facT=licznik/dlog(dexp(x)+dexp(-x))
 874         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 875         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 876         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 877         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 878       else
 879         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 880         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 881 #ifdef MPI
 882        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 883 #endif
 884        stop 555
 885       endif
 886       welec=weights(3)*fact
 887       wcorr=weights(4)*fact3
 888       wcorr5=weights(5)*fact4
 889       wcorr6=weights(6)*fact5
 890       wel_loc=weights(7)*fact2
 891       wturn3=weights(8)*fact2
 892       wturn4=weights(9)*fact3
 893       wturn6=weights(10)*fact5
 894       wtor=weights(13)*fact
 895       wtor_d=weights(14)*fact2
 896       wsccor=weights(21)*fact
 897
 898       return
 899       end
 900 C------------------------------------------------------------------------
 901       subroutine enerprint(energia)
 902       implicit real*8 (a-h,o-z)
 903       include 'DIMENSIONS'
 904       include 'COMMON.IOUNITS'
 905       include 'COMMON.FFIELD'
 906       include 'COMMON.SBRIDGE'
 907       include 'COMMON.MD'
 908       double precision energia(0:n_ene)
 909       etot=energia(0)
 910       evdw=energia(1)
 911       evdw2=energia(2)
 912 #ifdef SCP14
 913       evdw2=energia(2)+energia(18)
 914 #else
 915       evdw2=energia(2)
 916 #endif
 917       ees=energia(3)
 918 #ifdef SPLITELE
 919       evdw1=energia(16)
 920 #endif
 921       ecorr=energia(4)
 922       ecorr5=energia(5)
 923       ecorr6=energia(6)
 924       eel_loc=energia(7)
 925       eello_turn3=energia(8)
 926       eello_turn4=energia(9)
 927       eello_turn6=energia(10)
 928       ebe=energia(11)
 929       escloc=energia(12)
 930       etors=energia(13)
 931       etors_d=energia(14)
 932       ehpb=energia(15)
 933       edihcnstr=energia(19)
 934       estr=energia(17)
 935       Uconst=energia(20)
 936       esccor=energia(21)
 937 #ifdef SPLITELE
 938       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 939      &  estr,wbond,ebe,wang,
 940      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 941      &  ecorr,wcorr,
 942      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 943      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 944      &  edihcnstr,ebr*nss,
 945      &  Uconst,etot
 946    10 format (/'Virtual-chain energies:'//
 947      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 948      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 949      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 950      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 951      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 952      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 953      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 954      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 955      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 956      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 957      & ' (SS bridges & dist. cnstr.)'/
 958      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 959      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 960      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 961      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 962      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 963      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 964      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 965      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 966      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 967      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 968      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 969      & 'ETOT=  ',1pE16.6,' (total)')
 970 #else
 971       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 972      &  estr,wbond,ebe,wang,
 973      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 974      &  ecorr,wcorr,
 975      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 976      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 977      &  ebr*nss,Uconst,etot
 978    10 format (/'Virtual-chain energies:'//
 979      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 980      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 981      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 982      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 983      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 984      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 985      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 986      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 987      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 988      & ' (SS bridges & dist. cnstr.)'/
 989      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 990      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 991      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 992      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 993      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 994      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 995      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 996      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 997      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 998      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 999      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1000      & 'ETOT=  ',1pE16.6,' (total)')
1001 #endif
1002       return
1003       end
1004 C-----------------------------------------------------------------------
1005       subroutine elj(evdw)
1006 C
1007 C This subroutine calculates the interaction energy of nonbonded side chains
1008 C assuming the LJ potential of interaction.
1009 C
1010       implicit real*8 (a-h,o-z)
1011       include 'DIMENSIONS'
1012       parameter (accur=1.0d-10)
1013       include 'COMMON.GEO'
1014       include 'COMMON.VAR'
1015       include 'COMMON.LOCAL'
1016       include 'COMMON.CHAIN'
1017       include 'COMMON.DERIV'
1018       include 'COMMON.INTERACT'
1019       include 'COMMON.TORSION'
1020       include 'COMMON.SBRIDGE'
1021       include 'COMMON.NAMES'
1022       include 'COMMON.IOUNITS'
1023       include 'COMMON.CONTACTS'
1024       dimension gg(3)
1025 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1026       evdw=0.0D0
1027       do i=iatsc_s,iatsc_e
1028         itypi=itype(i)
1029         if (itypi.eq.21) cycle
1030         itypi1=itype(i+1)
1031         xi=c(1,nres+i)
1032         yi=c(2,nres+i)
1033         zi=c(3,nres+i)
1034 C Change 12/1/95
1035         num_conti=0
1036 C
1037 C Calculate SC interaction energy.
1038 C
1039         do iint=1,nint_gr(i)
1040 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1041 cd   &                  'iend=',iend(i,iint)
1042           do j=istart(i,iint),iend(i,iint)
1043             itypj=itype(j)
1044             if (itypj.eq.21) cycle
1045             xj=c(1,nres+j)-xi
1046             yj=c(2,nres+j)-yi
1047             zj=c(3,nres+j)-zi
1048 C Change 12/1/95 to calculate four-body interactions
1049             rij=xj*xj+yj*yj+zj*zj
1050             rrij=1.0D0/rij
1051 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1052             eps0ij=eps(itypi,itypj)
1053             fac=rrij**expon2
1054             e1=fac*fac*aa(itypi,itypj)
1055             e2=fac*bb(itypi,itypj)
1056             evdwij=e1+e2
1057 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1058 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1059 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1060 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1061 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1062 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1063             evdw=evdw+evdwij
1064 C
1065 C Calculate the components of the gradient in DC and X
1066 C
1067             fac=-rrij*(e1+evdwij)
1068             gg(1)=xj*fac
1069             gg(2)=yj*fac
1070             gg(3)=zj*fac
1071             do k=1,3
1072               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1073               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1074               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1075               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1076             enddo
1077 cgrad            do k=i,j-1
1078 cgrad              do l=1,3
1079 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1080 cgrad              enddo
1081 cgrad            enddo
1082 C
1083 C 12/1/95, revised on 5/20/97
1084 C
1085 C Calculate the contact function. The ith column of the array JCONT will
1086 C contain the numbers of atoms that make contacts with the atom I (of numbers
1087 C greater than I). The arrays FACONT and GACONT will contain the values of
1088 C the contact function and its derivative.
1089 C
1090 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1091 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1092 C Uncomment next line, if the correlation interactions are contact function only
1093             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1094               rij=dsqrt(rij)
1095               sigij=sigma(itypi,itypj)
1096               r0ij=rs0(itypi,itypj)
1097 C
1098 C Check whether the SC's are not too far to make a contact.
1099 C
1100               rcut=1.5d0*r0ij
1101               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1102 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1103 C
1104               if (fcont.gt.0.0D0) then
1105 C If the SC-SC distance if close to sigma, apply spline.
1106 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1107 cAdam &             fcont1,fprimcont1)
1108 cAdam           fcont1=1.0d0-fcont1
1109 cAdam           if (fcont1.gt.0.0d0) then
1110 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1111 cAdam             fcont=fcont*fcont1
1112 cAdam           endif
1113 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1114 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1115 cga             do k=1,3
1116 cga               gg(k)=gg(k)*eps0ij
1117 cga             enddo
1118 cga             eps0ij=-evdwij*eps0ij
1119 C Uncomment for AL's type of SC correlation interactions.
1120 cadam           eps0ij=-evdwij
1121                 num_conti=num_conti+1
1122                 jcont(num_conti,i)=j
1123                 facont(num_conti,i)=fcont*eps0ij
1124                 fprimcont=eps0ij*fprimcont/rij
1125                 fcont=expon*fcont
1126 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1127 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1128 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1129 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1130                 gacont(1,num_conti,i)=-fprimcont*xj
1131                 gacont(2,num_conti,i)=-fprimcont*yj
1132                 gacont(3,num_conti,i)=-fprimcont*zj
1133 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1134 cd              write (iout,'(2i3,3f10.5)')
1135 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1136               endif
1137             endif
1138           enddo      ! j
1139         enddo        ! iint
1140 C Change 12/1/95
1141         num_cont(i)=num_conti
1142       enddo          ! i
1143       do i=1,nct
1144         do j=1,3
1145           gvdwc(j,i)=expon*gvdwc(j,i)
1146           gvdwx(j,i)=expon*gvdwx(j,i)
1147         enddo
1148       enddo
1149 C******************************************************************************
1150 C
1151 C                              N O T E !!!
1152 C
1153 C To save time, the factor of EXPON has been extracted from ALL components
1154 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1155 C use!
1156 C
1157 C******************************************************************************
1158       return
1159       end
1160 C-----------------------------------------------------------------------------
1161       subroutine eljk(evdw)
1162 C
1163 C This subroutine calculates the interaction energy of nonbonded side chains
1164 C assuming the LJK potential of interaction.
1165 C
1166       implicit real*8 (a-h,o-z)
1167       include 'DIMENSIONS'
1168       include 'COMMON.GEO'
1169       include 'COMMON.VAR'
1170       include 'COMMON.LOCAL'
1171       include 'COMMON.CHAIN'
1172       include 'COMMON.DERIV'
1173       include 'COMMON.INTERACT'
1174       include 'COMMON.IOUNITS'
1175       include 'COMMON.NAMES'
1176       dimension gg(3)
1177       logical scheck
1178 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1179       evdw=0.0D0
1180       do i=iatsc_s,iatsc_e
1181         itypi=itype(i)
1182         if (itypi.eq.21) cycle
1183         itypi1=itype(i+1)
1184         xi=c(1,nres+i)
1185         yi=c(2,nres+i)
1186         zi=c(3,nres+i)
1187 C
1188 C Calculate SC interaction energy.
1189 C
1190         do iint=1,nint_gr(i)
1191           do j=istart(i,iint),iend(i,iint)
1192             itypj=itype(j)
1193             if (itypj.eq.21) cycle
1194             xj=c(1,nres+j)-xi
1195             yj=c(2,nres+j)-yi
1196             zj=c(3,nres+j)-zi
1197             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1198             fac_augm=rrij**expon
1199             e_augm=augm(itypi,itypj)*fac_augm
1200             r_inv_ij=dsqrt(rrij)
1201             rij=1.0D0/r_inv_ij
1202             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1203             fac=r_shift_inv**expon
1204             e1=fac*fac*aa(itypi,itypj)
1205             e2=fac*bb(itypi,itypj)
1206             evdwij=e_augm+e1+e2
1207 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1208 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1209 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1210 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1211 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1212 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1213 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1214             evdw=evdw+evdwij
1215 C
1216 C Calculate the components of the gradient in DC and X
1217 C
1218             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1219             gg(1)=xj*fac
1220             gg(2)=yj*fac
1221             gg(3)=zj*fac
1222             do k=1,3
1223               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1224               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1225               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1226               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1227             enddo
1228 cgrad            do k=i,j-1
1229 cgrad              do l=1,3
1230 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1231 cgrad              enddo
1232 cgrad            enddo
1233           enddo      ! j
1234         enddo        ! iint
1235       enddo          ! i
1236       do i=1,nct
1237         do j=1,3
1238           gvdwc(j,i)=expon*gvdwc(j,i)
1239           gvdwx(j,i)=expon*gvdwx(j,i)
1240         enddo
1241       enddo
1242       return
1243       end
1244 C-----------------------------------------------------------------------------
1245       subroutine ebp(evdw)
1246 C
1247 C This subroutine calculates the interaction energy of nonbonded side chains
1248 C assuming the Berne-Pechukas potential of interaction.
1249 C
1250       implicit real*8 (a-h,o-z)
1251       include 'DIMENSIONS'
1252       include 'COMMON.GEO'
1253       include 'COMMON.VAR'
1254       include 'COMMON.LOCAL'
1255       include 'COMMON.CHAIN'
1256       include 'COMMON.DERIV'
1257       include 'COMMON.NAMES'
1258       include 'COMMON.INTERACT'
1259       include 'COMMON.IOUNITS'
1260       include 'COMMON.CALC'
1261       common /srutu/ icall
1262 c     double precision rrsave(maxdim)
1263       logical lprn
1264       evdw=0.0D0
1265 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1266       evdw=0.0D0
1267 c     if (icall.eq.0) then
1268 c       lprn=.true.
1269 c     else
1270         lprn=.false.
1271 c     endif
1272       ind=0
1273       do i=iatsc_s,iatsc_e
1274         itypi=itype(i)
1275         if (itypi.eq.21) cycle
1276         itypi1=itype(i+1)
1277         xi=c(1,nres+i)
1278         yi=c(2,nres+i)
1279         zi=c(3,nres+i)
1280         dxi=dc_norm(1,nres+i)
1281         dyi=dc_norm(2,nres+i)
1282         dzi=dc_norm(3,nres+i)
1283 c        dsci_inv=dsc_inv(itypi)
1284         dsci_inv=vbld_inv(i+nres)
1285 C
1286 C Calculate SC interaction energy.
1287 C
1288         do iint=1,nint_gr(i)
1289           do j=istart(i,iint),iend(i,iint)
1290             ind=ind+1
1291             itypj=itype(j)
1292             if (itypj.eq.21) cycle
1293 c            dscj_inv=dsc_inv(itypj)
1294             dscj_inv=vbld_inv(j+nres)
1295             chi1=chi(itypi,itypj)
1296             chi2=chi(itypj,itypi)
1297             chi12=chi1*chi2
1298             chip1=chip(itypi)
1299             chip2=chip(itypj)
1300             chip12=chip1*chip2
1301             alf1=alp(itypi)
1302             alf2=alp(itypj)
1303             alf12=0.5D0*(alf1+alf2)
1304 C For diagnostics only!!!
1305 c           chi1=0.0D0
1306 c           chi2=0.0D0
1307 c           chi12=0.0D0
1308 c           chip1=0.0D0
1309 c           chip2=0.0D0
1310 c           chip12=0.0D0
1311 c           alf1=0.0D0
1312 c           alf2=0.0D0
1313 c           alf12=0.0D0
1314             xj=c(1,nres+j)-xi
1315             yj=c(2,nres+j)-yi
1316             zj=c(3,nres+j)-zi
1317             dxj=dc_norm(1,nres+j)
1318             dyj=dc_norm(2,nres+j)
1319             dzj=dc_norm(3,nres+j)
1320             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1321 cd          if (icall.eq.0) then
1322 cd            rrsave(ind)=rrij
1323 cd          else
1324 cd            rrij=rrsave(ind)
1325 cd          endif
1326             rij=dsqrt(rrij)
1327 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1328             call sc_angular
1329 C Calculate whole angle-dependent part of epsilon and contributions
1330 C to its derivatives
1331             fac=(rrij*sigsq)**expon2
1332             e1=fac*fac*aa(itypi,itypj)
1333             e2=fac*bb(itypi,itypj)
1334             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1335             eps2der=evdwij*eps3rt
1336             eps3der=evdwij*eps2rt
1337             evdwij=evdwij*eps2rt*eps3rt
1338             evdw=evdw+evdwij
1339             if (lprn) then
1340             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1341             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1342 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1343 cd     &        restyp(itypi),i,restyp(itypj),j,
1344 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1345 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1346 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1347 cd     &        evdwij
1348             endif
1349 C Calculate gradient components.
1350             e1=e1*eps1*eps2rt**2*eps3rt**2
1351             fac=-expon*(e1+evdwij)
1352             sigder=fac/sigsq
1353             fac=rrij*fac
1354 C Calculate radial part of the gradient
1355             gg(1)=xj*fac
1356             gg(2)=yj*fac
1357             gg(3)=zj*fac
1358 C Calculate the angular part of the gradient and sum add the contributions
1359 C to the appropriate components of the Cartesian gradient.
1360             call sc_grad
1361           enddo      ! j
1362         enddo        ! iint
1363       enddo          ! i
1364 c     stop
1365       return
1366       end
1367 C-----------------------------------------------------------------------------
1368       subroutine egb(evdw)
1369 C
1370 C This subroutine calculates the interaction energy of nonbonded side chains
1371 C assuming the Gay-Berne potential of interaction.
1372 C
1373       implicit real*8 (a-h,o-z)
1374       include 'DIMENSIONS'
1375       include 'COMMON.GEO'
1376       include 'COMMON.VAR'
1377       include 'COMMON.LOCAL'
1378       include 'COMMON.CHAIN'
1379       include 'COMMON.DERIV'
1380       include 'COMMON.NAMES'
1381       include 'COMMON.INTERACT'
1382       include 'COMMON.IOUNITS'
1383       include 'COMMON.CALC'
1384       include 'COMMON.CONTROL'
1385       logical lprn
1386       evdw=0.0D0
1387 ccccc      energy_dec=.false.
1388 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1389       evdw=0.0D0
1390       lprn=.false.
1391 c     if (icall.eq.0) lprn=.false.
1392       ind=0
1393       do i=iatsc_s,iatsc_e
1394         itypi=itype(i)
1395         if (itypi.eq.21) cycle
1396         itypi1=itype(i+1)
1397         xi=c(1,nres+i)
1398         yi=c(2,nres+i)
1399         zi=c(3,nres+i)
1400         dxi=dc_norm(1,nres+i)
1401         dyi=dc_norm(2,nres+i)
1402         dzi=dc_norm(3,nres+i)
1403 c        dsci_inv=dsc_inv(itypi)
1404         dsci_inv=vbld_inv(i+nres)
1405 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1406 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1407 C
1408 C Calculate SC interaction energy.
1409 C
1410         do iint=1,nint_gr(i)
1411           do j=istart(i,iint),iend(i,iint)
1412             ind=ind+1
1413             itypj=itype(j)
1414             if (itypj.eq.21) cycle
1415 c            dscj_inv=dsc_inv(itypj)
1416             dscj_inv=vbld_inv(j+nres)
1417 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1418 c     &       1.0d0/vbld(j+nres)
1419 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1420             sig0ij=sigma(itypi,itypj)
1421             chi1=chi(itypi,itypj)
1422             chi2=chi(itypj,itypi)
1423             chi12=chi1*chi2
1424             chip1=chip(itypi)
1425             chip2=chip(itypj)
1426             chip12=chip1*chip2
1427             alf1=alp(itypi)
1428             alf2=alp(itypj)
1429             alf12=0.5D0*(alf1+alf2)
1430 C For diagnostics only!!!
1431 c           chi1=0.0D0
1432 c           chi2=0.0D0
1433 c           chi12=0.0D0
1434 c           chip1=0.0D0
1435 c           chip2=0.0D0
1436 c           chip12=0.0D0
1437 c           alf1=0.0D0
1438 c           alf2=0.0D0
1439 c           alf12=0.0D0
1440             xj=c(1,nres+j)-xi
1441             yj=c(2,nres+j)-yi
1442             zj=c(3,nres+j)-zi
1443             dxj=dc_norm(1,nres+j)
1444             dyj=dc_norm(2,nres+j)
1445             dzj=dc_norm(3,nres+j)
1446 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1447 c            write (iout,*) "j",j," dc_norm",
1448 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1449             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1450             rij=dsqrt(rrij)
1451 C Calculate angle-dependent terms of energy and contributions to their
1452 C derivatives.
1453             call sc_angular
1454             sigsq=1.0D0/sigsq
1455             sig=sig0ij*dsqrt(sigsq)
1456             rij_shift=1.0D0/rij-sig+sig0ij
1457 c for diagnostics; uncomment
1458 c            rij_shift=1.2*sig0ij
1459 C I hate to put IF's in the loops, but here don't have another choice!!!!
1460             if (rij_shift.le.0.0D0) then
1461               evdw=1.0D20
1462 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1463 cd     &        restyp(itypi),i,restyp(itypj),j,
1464 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1465               return
1466             endif
1467             sigder=-sig*sigsq
1468 c---------------------------------------------------------------
1469             rij_shift=1.0D0/rij_shift
1470             fac=rij_shift**expon
1471             e1=fac*fac*aa(itypi,itypj)
1472             e2=fac*bb(itypi,itypj)
1473             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1474             eps2der=evdwij*eps3rt
1475             eps3der=evdwij*eps2rt
1476 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1477 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1478             evdwij=evdwij*eps2rt*eps3rt
1479             evdw=evdw+evdwij
1480             if (lprn) then
1481             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1482             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1483             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1484      &        restyp(itypi),i,restyp(itypj),j,
1485      &        epsi,sigm,chi1,chi2,chip1,chip2,
1486      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1487      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1488      &        evdwij
1489             endif
1490
1491             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1492      &                        'evdw',i,j,evdwij
1493
1494 C Calculate gradient components.
1495             e1=e1*eps1*eps2rt**2*eps3rt**2
1496             fac=-expon*(e1+evdwij)*rij_shift
1497             sigder=fac*sigder
1498             fac=rij*fac
1499 c            fac=0.0d0
1500 C Calculate the radial part of the gradient
1501             gg(1)=xj*fac
1502             gg(2)=yj*fac
1503             gg(3)=zj*fac
1504 C Calculate angular part of the gradient.
1505             call sc_grad
1506           enddo      ! j
1507         enddo        ! iint
1508       enddo          ! i
1509 c      write (iout,*) "Number of loop steps in EGB:",ind
1510 cccc      energy_dec=.false.
1511       return
1512       end
1513 C-----------------------------------------------------------------------------
1514       subroutine egbv(evdw)
1515 C
1516 C This subroutine calculates the interaction energy of nonbonded side chains
1517 C assuming the Gay-Berne-Vorobjev potential of interaction.
1518 C
1519       implicit real*8 (a-h,o-z)
1520       include 'DIMENSIONS'
1521       include 'COMMON.GEO'
1522       include 'COMMON.VAR'
1523       include 'COMMON.LOCAL'
1524       include 'COMMON.CHAIN'
1525       include 'COMMON.DERIV'
1526       include 'COMMON.NAMES'
1527       include 'COMMON.INTERACT'
1528       include 'COMMON.IOUNITS'
1529       include 'COMMON.CALC'
1530       common /srutu/ icall
1531       logical lprn
1532       evdw=0.0D0
1533 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1534       evdw=0.0D0
1535       lprn=.false.
1536 c     if (icall.eq.0) lprn=.true.
1537       ind=0
1538       do i=iatsc_s,iatsc_e
1539         itypi=itype(i)
1540         if (itypi.eq.21) cycle
1541         itypi1=itype(i+1)
1542         xi=c(1,nres+i)
1543         yi=c(2,nres+i)
1544         zi=c(3,nres+i)
1545         dxi=dc_norm(1,nres+i)
1546         dyi=dc_norm(2,nres+i)
1547         dzi=dc_norm(3,nres+i)
1548 c        dsci_inv=dsc_inv(itypi)
1549         dsci_inv=vbld_inv(i+nres)
1550 C
1551 C Calculate SC interaction energy.
1552 C
1553         do iint=1,nint_gr(i)
1554           do j=istart(i,iint),iend(i,iint)
1555             ind=ind+1
1556             itypj=itype(j)
1557             if (itypj.eq.21) cycle
1558 c            dscj_inv=dsc_inv(itypj)
1559             dscj_inv=vbld_inv(j+nres)
1560             sig0ij=sigma(itypi,itypj)
1561             r0ij=r0(itypi,itypj)
1562             chi1=chi(itypi,itypj)
1563             chi2=chi(itypj,itypi)
1564             chi12=chi1*chi2
1565             chip1=chip(itypi)
1566             chip2=chip(itypj)
1567             chip12=chip1*chip2
1568             alf1=alp(itypi)
1569             alf2=alp(itypj)
1570             alf12=0.5D0*(alf1+alf2)
1571 C For diagnostics only!!!
1572 c           chi1=0.0D0
1573 c           chi2=0.0D0
1574 c           chi12=0.0D0
1575 c           chip1=0.0D0
1576 c           chip2=0.0D0
1577 c           chip12=0.0D0
1578 c           alf1=0.0D0
1579 c           alf2=0.0D0
1580 c           alf12=0.0D0
1581             xj=c(1,nres+j)-xi
1582             yj=c(2,nres+j)-yi
1583             zj=c(3,nres+j)-zi
1584             dxj=dc_norm(1,nres+j)
1585             dyj=dc_norm(2,nres+j)
1586             dzj=dc_norm(3,nres+j)
1587             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1588             rij=dsqrt(rrij)
1589 C Calculate angle-dependent terms of energy and contributions to their
1590 C derivatives.
1591             call sc_angular
1592             sigsq=1.0D0/sigsq
1593             sig=sig0ij*dsqrt(sigsq)
1594             rij_shift=1.0D0/rij-sig+r0ij
1595 C I hate to put IF's in the loops, but here don't have another choice!!!!
1596             if (rij_shift.le.0.0D0) then
1597               evdw=1.0D20
1598               return
1599             endif
1600             sigder=-sig*sigsq
1601 c---------------------------------------------------------------
1602             rij_shift=1.0D0/rij_shift
1603             fac=rij_shift**expon
1604             e1=fac*fac*aa(itypi,itypj)
1605             e2=fac*bb(itypi,itypj)
1606             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1607             eps2der=evdwij*eps3rt
1608             eps3der=evdwij*eps2rt
1609             fac_augm=rrij**expon
1610             e_augm=augm(itypi,itypj)*fac_augm
1611             evdwij=evdwij*eps2rt*eps3rt
1612             evdw=evdw+evdwij+e_augm
1613             if (lprn) then
1614             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1615             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1616             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1617      &        restyp(itypi),i,restyp(itypj),j,
1618      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1619      &        chi1,chi2,chip1,chip2,
1620      &        eps1,eps2rt**2,eps3rt**2,
1621      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1622      &        evdwij+e_augm
1623             endif
1624 C Calculate gradient components.
1625             e1=e1*eps1*eps2rt**2*eps3rt**2
1626             fac=-expon*(e1+evdwij)*rij_shift
1627             sigder=fac*sigder
1628             fac=rij*fac-2*expon*rrij*e_augm
1629 C Calculate the radial part of the gradient
1630             gg(1)=xj*fac
1631             gg(2)=yj*fac
1632             gg(3)=zj*fac
1633 C Calculate angular part of the gradient.
1634             call sc_grad
1635           enddo      ! j
1636         enddo        ! iint
1637       enddo          ! i
1638       end
1639 C-----------------------------------------------------------------------------
1640       subroutine sc_angular
1641 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1642 C om12. Called by ebp, egb, and egbv.
1643       implicit none
1644       include 'COMMON.CALC'
1645       include 'COMMON.IOUNITS'
1646       erij(1)=xj*rij
1647       erij(2)=yj*rij
1648       erij(3)=zj*rij
1649       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1650       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1651       om12=dxi*dxj+dyi*dyj+dzi*dzj
1652       chiom12=chi12*om12
1653 C Calculate eps1(om12) and its derivative in om12
1654       faceps1=1.0D0-om12*chiom12
1655       faceps1_inv=1.0D0/faceps1
1656       eps1=dsqrt(faceps1_inv)
1657 C Following variable is eps1*deps1/dom12
1658       eps1_om12=faceps1_inv*chiom12
1659 c diagnostics only
1660 c      faceps1_inv=om12
1661 c      eps1=om12
1662 c      eps1_om12=1.0d0
1663 c      write (iout,*) "om12",om12," eps1",eps1
1664 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1665 C and om12.
1666       om1om2=om1*om2
1667       chiom1=chi1*om1
1668       chiom2=chi2*om2
1669       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1670       sigsq=1.0D0-facsig*faceps1_inv
1671       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1672       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1673       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1674 c diagnostics only
1675 c      sigsq=1.0d0
1676 c      sigsq_om1=0.0d0
1677 c      sigsq_om2=0.0d0
1678 c      sigsq_om12=0.0d0
1679 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1680 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1681 c     &    " eps1",eps1
1682 C Calculate eps2 and its derivatives in om1, om2, and om12.
1683       chipom1=chip1*om1
1684       chipom2=chip2*om2
1685       chipom12=chip12*om12
1686       facp=1.0D0-om12*chipom12
1687       facp_inv=1.0D0/facp
1688       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1689 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1690 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1691 C Following variable is the square root of eps2
1692       eps2rt=1.0D0-facp1*facp_inv
1693 C Following three variables are the derivatives of the square root of eps
1694 C in om1, om2, and om12.
1695       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1696       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1697       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1698 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1699       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1700 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1701 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1702 c     &  " eps2rt_om12",eps2rt_om12
1703 C Calculate whole angle-dependent part of epsilon and contributions
1704 C to its derivatives
1705       return
1706       end
1707 C----------------------------------------------------------------------------
1708       subroutine sc_grad
1709       implicit real*8 (a-h,o-z)
1710       include 'DIMENSIONS'
1711       include 'COMMON.CHAIN'
1712       include 'COMMON.DERIV'
1713       include 'COMMON.CALC'
1714       include 'COMMON.IOUNITS'
1715       double precision dcosom1(3),dcosom2(3)
1716       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1717       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1718       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1719      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1720 c diagnostics only
1721 c      eom1=0.0d0
1722 c      eom2=0.0d0
1723 c      eom12=evdwij*eps1_om12
1724 c end diagnostics
1725 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1726 c     &  " sigder",sigder
1727 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1728 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1729       do k=1,3
1730         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1731         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1732       enddo
1733       do k=1,3
1734         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1735       enddo
1736 c      write (iout,*) "gg",(gg(k),k=1,3)
1737       do k=1,3
1738         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1739      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1740      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1741         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1742      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1743      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1744 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1745 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1746 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1747 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1748       enddo
1749 C
1750 C Calculate the components of the gradient in DC and X
1751 C
1752 cgrad      do k=i,j-1
1753 cgrad        do l=1,3
1754 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1755 cgrad        enddo
1756 cgrad      enddo
1757       do l=1,3
1758         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1759         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1760       enddo
1761       return
1762       end
1763 C-----------------------------------------------------------------------
1764       subroutine e_softsphere(evdw)
1765 C
1766 C This subroutine calculates the interaction energy of nonbonded side chains
1767 C assuming the LJ potential of interaction.
1768 C
1769       implicit real*8 (a-h,o-z)
1770       include 'DIMENSIONS'
1771       parameter (accur=1.0d-10)
1772       include 'COMMON.GEO'
1773       include 'COMMON.VAR'
1774       include 'COMMON.LOCAL'
1775       include 'COMMON.CHAIN'
1776       include 'COMMON.DERIV'
1777       include 'COMMON.INTERACT'
1778       include 'COMMON.TORSION'
1779       include 'COMMON.SBRIDGE'
1780       include 'COMMON.NAMES'
1781       include 'COMMON.IOUNITS'
1782       include 'COMMON.CONTACTS'
1783       dimension gg(3)
1784 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1785       evdw=0.0D0
1786       do i=iatsc_s,iatsc_e
1787         itypi=itype(i)
1788         if (itypi.eq.21) cycle
1789         itypi1=itype(i+1)
1790         xi=c(1,nres+i)
1791         yi=c(2,nres+i)
1792         zi=c(3,nres+i)
1793 C
1794 C Calculate SC interaction energy.
1795 C
1796         do iint=1,nint_gr(i)
1797 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1798 cd   &                  'iend=',iend(i,iint)
1799           do j=istart(i,iint),iend(i,iint)
1800             itypj=itype(j)
1801             if (itypj.eq.21) cycle
1802             xj=c(1,nres+j)-xi
1803             yj=c(2,nres+j)-yi
1804             zj=c(3,nres+j)-zi
1805             rij=xj*xj+yj*yj+zj*zj
1806 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1807             r0ij=r0(itypi,itypj)
1808             r0ijsq=r0ij*r0ij
1809 c            print *,i,j,r0ij,dsqrt(rij)
1810             if (rij.lt.r0ijsq) then
1811               evdwij=0.25d0*(rij-r0ijsq)**2
1812               fac=rij-r0ijsq
1813             else
1814               evdwij=0.0d0
1815               fac=0.0d0
1816             endif
1817             evdw=evdw+evdwij
1818 C
1819 C Calculate the components of the gradient in DC and X
1820 C
1821             gg(1)=xj*fac
1822             gg(2)=yj*fac
1823             gg(3)=zj*fac
1824             do k=1,3
1825               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1826               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1827               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1828               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1829             enddo
1830 cgrad            do k=i,j-1
1831 cgrad              do l=1,3
1832 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1833 cgrad              enddo
1834 cgrad            enddo
1835           enddo ! j
1836         enddo ! iint
1837       enddo ! i
1838       return
1839       end
1840 C--------------------------------------------------------------------------
1841       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1842      &              eello_turn4)
1843 C
1844 C Soft-sphere potential of p-p interaction
1845 C
1846       implicit real*8 (a-h,o-z)
1847       include 'DIMENSIONS'
1848       include 'COMMON.CONTROL'
1849       include 'COMMON.IOUNITS'
1850       include 'COMMON.GEO'
1851       include 'COMMON.VAR'
1852       include 'COMMON.LOCAL'
1853       include 'COMMON.CHAIN'
1854       include 'COMMON.DERIV'
1855       include 'COMMON.INTERACT'
1856       include 'COMMON.CONTACTS'
1857       include 'COMMON.TORSION'
1858       include 'COMMON.VECTORS'
1859       include 'COMMON.FFIELD'
1860       dimension ggg(3)
1861 cd      write(iout,*) 'In EELEC_soft_sphere'
1862       ees=0.0D0
1863       evdw1=0.0D0
1864       eel_loc=0.0d0
1865       eello_turn3=0.0d0
1866       eello_turn4=0.0d0
1867       ind=0
1868       do i=iatel_s,iatel_e
1869         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
1870         dxi=dc(1,i)
1871         dyi=dc(2,i)
1872         dzi=dc(3,i)
1873         xmedi=c(1,i)+0.5d0*dxi
1874         ymedi=c(2,i)+0.5d0*dyi
1875         zmedi=c(3,i)+0.5d0*dzi
1876         num_conti=0
1877 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1878         do j=ielstart(i),ielend(i)
1879           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
1880           ind=ind+1
1881           iteli=itel(i)
1882           itelj=itel(j)
1883           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1884           r0ij=rpp(iteli,itelj)
1885           r0ijsq=r0ij*r0ij
1886           dxj=dc(1,j)
1887           dyj=dc(2,j)
1888           dzj=dc(3,j)
1889           xj=c(1,j)+0.5D0*dxj-xmedi
1890           yj=c(2,j)+0.5D0*dyj-ymedi
1891           zj=c(3,j)+0.5D0*dzj-zmedi
1892           rij=xj*xj+yj*yj+zj*zj
1893           if (rij.lt.r0ijsq) then
1894             evdw1ij=0.25d0*(rij-r0ijsq)**2
1895             fac=rij-r0ijsq
1896           else
1897             evdw1ij=0.0d0
1898             fac=0.0d0
1899           endif
1900           evdw1=evdw1+evdw1ij
1901 C
1902 C Calculate contributions to the Cartesian gradient.
1903 C
1904           ggg(1)=fac*xj
1905           ggg(2)=fac*yj
1906           ggg(3)=fac*zj
1907           do k=1,3
1908             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1909             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1910           enddo
1911 *
1912 * Loop over residues i+1 thru j-1.
1913 *
1914 cgrad          do k=i+1,j-1
1915 cgrad            do l=1,3
1916 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1917 cgrad            enddo
1918 cgrad          enddo
1919         enddo ! j
1920       enddo   ! i
1921 cgrad      do i=nnt,nct-1
1922 cgrad        do k=1,3
1923 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1924 cgrad        enddo
1925 cgrad        do j=i+1,nct-1
1926 cgrad          do k=1,3
1927 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1928 cgrad          enddo
1929 cgrad        enddo
1930 cgrad      enddo
1931       return
1932       end
1933 c------------------------------------------------------------------------------
1934       subroutine vec_and_deriv
1935       implicit real*8 (a-h,o-z)
1936       include 'DIMENSIONS'
1937 #ifdef MPI
1938       include 'mpif.h'
1939 #endif
1940       include 'COMMON.IOUNITS'
1941       include 'COMMON.GEO'
1942       include 'COMMON.VAR'
1943       include 'COMMON.LOCAL'
1944       include 'COMMON.CHAIN'
1945       include 'COMMON.VECTORS'
1946       include 'COMMON.SETUP'
1947       include 'COMMON.TIME1'
1948       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1949 C Compute the local reference systems. For reference system (i), the
1950 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1951 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1952 #ifdef PARVEC
1953       do i=ivec_start,ivec_end
1954 #else
1955       do i=1,nres-1
1956 #endif
1957           if (i.eq.nres-1) then
1958 C Case of the last full residue
1959 C Compute the Z-axis
1960             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1961             costh=dcos(pi-theta(nres))
1962             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1963             do k=1,3
1964               uz(k,i)=fac*uz(k,i)
1965             enddo
1966 C Compute the derivatives of uz
1967             uzder(1,1,1)= 0.0d0
1968             uzder(2,1,1)=-dc_norm(3,i-1)
1969             uzder(3,1,1)= dc_norm(2,i-1)
1970             uzder(1,2,1)= dc_norm(3,i-1)
1971             uzder(2,2,1)= 0.0d0
1972             uzder(3,2,1)=-dc_norm(1,i-1)
1973             uzder(1,3,1)=-dc_norm(2,i-1)
1974             uzder(2,3,1)= dc_norm(1,i-1)
1975             uzder(3,3,1)= 0.0d0
1976             uzder(1,1,2)= 0.0d0
1977             uzder(2,1,2)= dc_norm(3,i)
1978             uzder(3,1,2)=-dc_norm(2,i)
1979             uzder(1,2,2)=-dc_norm(3,i)
1980             uzder(2,2,2)= 0.0d0
1981             uzder(3,2,2)= dc_norm(1,i)
1982             uzder(1,3,2)= dc_norm(2,i)
1983             uzder(2,3,2)=-dc_norm(1,i)
1984             uzder(3,3,2)= 0.0d0
1985 C Compute the Y-axis
1986             facy=fac
1987             do k=1,3
1988               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1989             enddo
1990 C Compute the derivatives of uy
1991             do j=1,3
1992               do k=1,3
1993                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1994      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1995                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1996               enddo
1997               uyder(j,j,1)=uyder(j,j,1)-costh
1998               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1999             enddo
2000             do j=1,2
2001               do k=1,3
2002                 do l=1,3
2003                   uygrad(l,k,j,i)=uyder(l,k,j)
2004                   uzgrad(l,k,j,i)=uzder(l,k,j)
2005                 enddo
2006               enddo
2007             enddo
2008             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2009             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2010             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2011             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2012           else
2013 C Other residues
2014 C Compute the Z-axis
2015             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2016             costh=dcos(pi-theta(i+2))
2017             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2018             do k=1,3
2019               uz(k,i)=fac*uz(k,i)
2020             enddo
2021 C Compute the derivatives of uz
2022             uzder(1,1,1)= 0.0d0
2023             uzder(2,1,1)=-dc_norm(3,i+1)
2024             uzder(3,1,1)= dc_norm(2,i+1)
2025             uzder(1,2,1)= dc_norm(3,i+1)
2026             uzder(2,2,1)= 0.0d0
2027             uzder(3,2,1)=-dc_norm(1,i+1)
2028             uzder(1,3,1)=-dc_norm(2,i+1)
2029             uzder(2,3,1)= dc_norm(1,i+1)
2030             uzder(3,3,1)= 0.0d0
2031             uzder(1,1,2)= 0.0d0
2032             uzder(2,1,2)= dc_norm(3,i)
2033             uzder(3,1,2)=-dc_norm(2,i)
2034             uzder(1,2,2)=-dc_norm(3,i)
2035             uzder(2,2,2)= 0.0d0
2036             uzder(3,2,2)= dc_norm(1,i)
2037             uzder(1,3,2)= dc_norm(2,i)
2038             uzder(2,3,2)=-dc_norm(1,i)
2039             uzder(3,3,2)= 0.0d0
2040 C Compute the Y-axis
2041             facy=fac
2042             do k=1,3
2043               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2044             enddo
2045 C Compute the derivatives of uy
2046             do j=1,3
2047               do k=1,3
2048                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2049      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2050                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2051               enddo
2052               uyder(j,j,1)=uyder(j,j,1)-costh
2053               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2054             enddo
2055             do j=1,2
2056               do k=1,3
2057                 do l=1,3
2058                   uygrad(l,k,j,i)=uyder(l,k,j)
2059                   uzgrad(l,k,j,i)=uzder(l,k,j)
2060                 enddo
2061               enddo
2062             enddo
2063             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2064             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2065             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2066             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2067           endif
2068       enddo
2069       do i=1,nres-1
2070         vbld_inv_temp(1)=vbld_inv(i+1)
2071         if (i.lt.nres-1) then
2072           vbld_inv_temp(2)=vbld_inv(i+2)
2073           else
2074           vbld_inv_temp(2)=vbld_inv(i)
2075           endif
2076         do j=1,2
2077           do k=1,3
2078             do l=1,3
2079               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2080               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2081             enddo
2082           enddo
2083         enddo
2084       enddo
2085 #if defined(PARVEC) && defined(MPI)
2086       if (nfgtasks1.gt.1) then
2087         time00=MPI_Wtime()
2088 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2089 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2090 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2091         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2092      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2093      &   FG_COMM1,IERR)
2094         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2095      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2096      &   FG_COMM1,IERR)
2097         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2098      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2099      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2100         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2101      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2102      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2103         time_gather=time_gather+MPI_Wtime()-time00
2104       endif
2105 c      if (fg_rank.eq.0) then
2106 c        write (iout,*) "Arrays UY and UZ"
2107 c        do i=1,nres-1
2108 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2109 c     &     (uz(k,i),k=1,3)
2110 c        enddo
2111 c      endif
2112 #endif
2113       return
2114       end
2115 C-----------------------------------------------------------------------------
2116       subroutine check_vecgrad
2117       implicit real*8 (a-h,o-z)
2118       include 'DIMENSIONS'
2119       include 'COMMON.IOUNITS'
2120       include 'COMMON.GEO'
2121       include 'COMMON.VAR'
2122       include 'COMMON.LOCAL'
2123       include 'COMMON.CHAIN'
2124       include 'COMMON.VECTORS'
2125       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2126       dimension uyt(3,maxres),uzt(3,maxres)
2127       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2128       double precision delta /1.0d-7/
2129       call vec_and_deriv
2130 cd      do i=1,nres
2131 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2132 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2133 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2134 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2135 cd     &     (dc_norm(if90,i),if90=1,3)
2136 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2137 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2138 cd          write(iout,'(a)')
2139 cd      enddo
2140       do i=1,nres
2141         do j=1,2
2142           do k=1,3
2143             do l=1,3
2144               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2145               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2146             enddo
2147           enddo
2148         enddo
2149       enddo
2150       call vec_and_deriv
2151       do i=1,nres
2152         do j=1,3
2153           uyt(j,i)=uy(j,i)
2154           uzt(j,i)=uz(j,i)
2155         enddo
2156       enddo
2157       do i=1,nres
2158 cd        write (iout,*) 'i=',i
2159         do k=1,3
2160           erij(k)=dc_norm(k,i)
2161         enddo
2162         do j=1,3
2163           do k=1,3
2164             dc_norm(k,i)=erij(k)
2165           enddo
2166           dc_norm(j,i)=dc_norm(j,i)+delta
2167 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2168 c          do k=1,3
2169 c            dc_norm(k,i)=dc_norm(k,i)/fac
2170 c          enddo
2171 c          write (iout,*) (dc_norm(k,i),k=1,3)
2172 c          write (iout,*) (erij(k),k=1,3)
2173           call vec_and_deriv
2174           do k=1,3
2175             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2176             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2177             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2178             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2179           enddo
2180 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2181 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2182 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2183         enddo
2184         do k=1,3
2185           dc_norm(k,i)=erij(k)
2186         enddo
2187 cd        do k=1,3
2188 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2189 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2190 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2191 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2192 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2193 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2194 cd          write (iout,'(a)')
2195 cd        enddo
2196       enddo
2197       return
2198       end
2199 C--------------------------------------------------------------------------
2200       subroutine set_matrices
2201       implicit real*8 (a-h,o-z)
2202       include 'DIMENSIONS'
2203 #ifdef MPI
2204       include "mpif.h"
2205       include "COMMON.SETUP"
2206       integer IERR
2207       integer status(MPI_STATUS_SIZE)
2208 #endif
2209       include 'COMMON.IOUNITS'
2210       include 'COMMON.GEO'
2211       include 'COMMON.VAR'
2212       include 'COMMON.LOCAL'
2213       include 'COMMON.CHAIN'
2214       include 'COMMON.DERIV'
2215       include 'COMMON.INTERACT'
2216       include 'COMMON.CONTACTS'
2217       include 'COMMON.TORSION'
2218       include 'COMMON.VECTORS'
2219       include 'COMMON.FFIELD'
2220       double precision auxvec(2),auxmat(2,2)
2221 C
2222 C Compute the virtual-bond-torsional-angle dependent quantities needed
2223 C to calculate the el-loc multibody terms of various order.
2224 C
2225 #ifdef PARMAT
2226       do i=ivec_start+2,ivec_end+2
2227 #else
2228       do i=3,nres+1
2229 #endif
2230         if (i .lt. nres+1) then
2231           sin1=dsin(phi(i))
2232           cos1=dcos(phi(i))
2233           sintab(i-2)=sin1
2234           costab(i-2)=cos1
2235           obrot(1,i-2)=cos1
2236           obrot(2,i-2)=sin1
2237           sin2=dsin(2*phi(i))
2238           cos2=dcos(2*phi(i))
2239           sintab2(i-2)=sin2
2240           costab2(i-2)=cos2
2241           obrot2(1,i-2)=cos2
2242           obrot2(2,i-2)=sin2
2243           Ug(1,1,i-2)=-cos1
2244           Ug(1,2,i-2)=-sin1
2245           Ug(2,1,i-2)=-sin1
2246           Ug(2,2,i-2)= cos1
2247           Ug2(1,1,i-2)=-cos2
2248           Ug2(1,2,i-2)=-sin2
2249           Ug2(2,1,i-2)=-sin2
2250           Ug2(2,2,i-2)= cos2
2251         else
2252           costab(i-2)=1.0d0
2253           sintab(i-2)=0.0d0
2254           obrot(1,i-2)=1.0d0
2255           obrot(2,i-2)=0.0d0
2256           obrot2(1,i-2)=0.0d0
2257           obrot2(2,i-2)=0.0d0
2258           Ug(1,1,i-2)=1.0d0
2259           Ug(1,2,i-2)=0.0d0
2260           Ug(2,1,i-2)=0.0d0
2261           Ug(2,2,i-2)=1.0d0
2262           Ug2(1,1,i-2)=0.0d0
2263           Ug2(1,2,i-2)=0.0d0
2264           Ug2(2,1,i-2)=0.0d0
2265           Ug2(2,2,i-2)=0.0d0
2266         endif
2267         if (i .gt. 3 .and. i .lt. nres+1) then
2268           obrot_der(1,i-2)=-sin1
2269           obrot_der(2,i-2)= cos1
2270           Ugder(1,1,i-2)= sin1
2271           Ugder(1,2,i-2)=-cos1
2272           Ugder(2,1,i-2)=-cos1
2273           Ugder(2,2,i-2)=-sin1
2274           dwacos2=cos2+cos2
2275           dwasin2=sin2+sin2
2276           obrot2_der(1,i-2)=-dwasin2
2277           obrot2_der(2,i-2)= dwacos2
2278           Ug2der(1,1,i-2)= dwasin2
2279           Ug2der(1,2,i-2)=-dwacos2
2280           Ug2der(2,1,i-2)=-dwacos2
2281           Ug2der(2,2,i-2)=-dwasin2
2282         else
2283           obrot_der(1,i-2)=0.0d0
2284           obrot_der(2,i-2)=0.0d0
2285           Ugder(1,1,i-2)=0.0d0
2286           Ugder(1,2,i-2)=0.0d0
2287           Ugder(2,1,i-2)=0.0d0
2288           Ugder(2,2,i-2)=0.0d0
2289           obrot2_der(1,i-2)=0.0d0
2290           obrot2_der(2,i-2)=0.0d0
2291           Ug2der(1,1,i-2)=0.0d0
2292           Ug2der(1,2,i-2)=0.0d0
2293           Ug2der(2,1,i-2)=0.0d0
2294           Ug2der(2,2,i-2)=0.0d0
2295         endif
2296 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2297         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2298           iti = itortyp(itype(i-2))
2299         else
2300           iti=ntortyp+1
2301         endif
2302 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2303         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2304           iti1 = itortyp(itype(i-1))
2305         else
2306           iti1=ntortyp+1
2307         endif
2308 cd        write (iout,*) '*******i',i,' iti1',iti
2309 cd        write (iout,*) 'b1',b1(:,iti)
2310 cd        write (iout,*) 'b2',b2(:,iti)
2311 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2312 c        if (i .gt. iatel_s+2) then
2313         if (i .gt. nnt+2) then
2314           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2315           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2316           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2317      &    then
2318           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2319           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2320           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2321           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2322           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2323           endif
2324         else
2325           do k=1,2
2326             Ub2(k,i-2)=0.0d0
2327             Ctobr(k,i-2)=0.0d0
2328             Dtobr2(k,i-2)=0.0d0
2329             do l=1,2
2330               EUg(l,k,i-2)=0.0d0
2331               CUg(l,k,i-2)=0.0d0
2332               DUg(l,k,i-2)=0.0d0
2333               DtUg2(l,k,i-2)=0.0d0
2334             enddo
2335           enddo
2336         endif
2337         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2338         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2339         do k=1,2
2340           muder(k,i-2)=Ub2der(k,i-2)
2341         enddo
2342 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2343         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2344           iti1 = itortyp(itype(i-1))
2345         else
2346           iti1=ntortyp+1
2347         endif
2348         do k=1,2
2349           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2350         enddo
2351 cd        write (iout,*) 'mu ',mu(:,i-2)
2352 cd        write (iout,*) 'mu1',mu1(:,i-2)
2353 cd        write (iout,*) 'mu2',mu2(:,i-2)
2354         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2355      &  then
2356         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2357         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2358         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2359         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2360         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2361 C Vectors and matrices dependent on a single virtual-bond dihedral.
2362         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2363         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2364         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2365         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2366         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2367         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2368         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2369         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2370         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2371         endif
2372       enddo
2373 C Matrices dependent on two consecutive virtual-bond dihedrals.
2374 C The order of matrices is from left to right.
2375       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2376      &then
2377 c      do i=max0(ivec_start,2),ivec_end
2378       do i=2,nres-1
2379         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2380         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2381         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2382         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2383         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2384         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2385         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2386         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2387       enddo
2388       endif
2389 #if defined(MPI) && defined(PARMAT)
2390 #ifdef DEBUG
2391 c      if (fg_rank.eq.0) then
2392         write (iout,*) "Arrays UG and UGDER before GATHER"
2393         do i=1,nres-1
2394           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2395      &     ((ug(l,k,i),l=1,2),k=1,2),
2396      &     ((ugder(l,k,i),l=1,2),k=1,2)
2397         enddo
2398         write (iout,*) "Arrays UG2 and UG2DER"
2399         do i=1,nres-1
2400           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2401      &     ((ug2(l,k,i),l=1,2),k=1,2),
2402      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2403         enddo
2404         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2405         do i=1,nres-1
2406           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2407      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2408      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2409         enddo
2410         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2411         do i=1,nres-1
2412           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2413      &     costab(i),sintab(i),costab2(i),sintab2(i)
2414         enddo
2415         write (iout,*) "Array MUDER"
2416         do i=1,nres-1
2417           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2418         enddo
2419 c      endif
2420 #endif
2421       if (nfgtasks.gt.1) then
2422         time00=MPI_Wtime()
2423 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2424 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2425 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2426 #ifdef MATGATHER
2427         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2428      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2429      &   FG_COMM1,IERR)
2430         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2431      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2432      &   FG_COMM1,IERR)
2433         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2434      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2435      &   FG_COMM1,IERR)
2436         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2437      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2438      &   FG_COMM1,IERR)
2439         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2440      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2441      &   FG_COMM1,IERR)
2442         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2443      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2444      &   FG_COMM1,IERR)
2445         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2446      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2447      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2448         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2449      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2450      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2451         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2452      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2453      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2454         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2455      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2456      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2457         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2458      &  then
2459         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2460      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2461      &   FG_COMM1,IERR)
2462         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2463      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2464      &   FG_COMM1,IERR)
2465         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2466      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2467      &   FG_COMM1,IERR)
2468        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2469      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2470      &   FG_COMM1,IERR)
2471         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2472      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2473      &   FG_COMM1,IERR)
2474         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2475      &   ivec_count(fg_rank1),
2476      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2477      &   FG_COMM1,IERR)
2478         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2479      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2480      &   FG_COMM1,IERR)
2481         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2482      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2483      &   FG_COMM1,IERR)
2484         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2485      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2486      &   FG_COMM1,IERR)
2487         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2488      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2489      &   FG_COMM1,IERR)
2490         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2491      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2492      &   FG_COMM1,IERR)
2493         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2494      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2495      &   FG_COMM1,IERR)
2496         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2497      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2498      &   FG_COMM1,IERR)
2499         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2500      &   ivec_count(fg_rank1),
2501      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2502      &   FG_COMM1,IERR)
2503         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2504      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2505      &   FG_COMM1,IERR)
2506        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2507      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2508      &   FG_COMM1,IERR)
2509         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2510      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2511      &   FG_COMM1,IERR)
2512        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2513      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2514      &   FG_COMM1,IERR)
2515         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2516      &   ivec_count(fg_rank1),
2517      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2518      &   FG_COMM1,IERR)
2519         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2520      &   ivec_count(fg_rank1),
2521      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2522      &   FG_COMM1,IERR)
2523         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2524      &   ivec_count(fg_rank1),
2525      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2526      &   MPI_MAT2,FG_COMM1,IERR)
2527         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2528      &   ivec_count(fg_rank1),
2529      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2530      &   MPI_MAT2,FG_COMM1,IERR)
2531         endif
2532 #else
2533 c Passes matrix info through the ring
2534       isend=fg_rank1
2535       irecv=fg_rank1-1
2536       if (irecv.lt.0) irecv=nfgtasks1-1
2537       iprev=irecv
2538       inext=fg_rank1+1
2539       if (inext.ge.nfgtasks1) inext=0
2540       do i=1,nfgtasks1-1
2541 c        write (iout,*) "isend",isend," irecv",irecv
2542 c        call flush(iout)
2543         lensend=lentyp(isend)
2544         lenrecv=lentyp(irecv)
2545 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2546 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2547 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2548 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2549 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2550 c        write (iout,*) "Gather ROTAT1"
2551 c        call flush(iout)
2552 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2553 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2554 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2555 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2556 c        write (iout,*) "Gather ROTAT2"
2557 c        call flush(iout)
2558         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2559      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2560      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2561      &   iprev,4400+irecv,FG_COMM,status,IERR)
2562 c        write (iout,*) "Gather ROTAT_OLD"
2563 c        call flush(iout)
2564         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2565      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2566      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2567      &   iprev,5500+irecv,FG_COMM,status,IERR)
2568 c        write (iout,*) "Gather PRECOMP11"
2569 c        call flush(iout)
2570         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2571      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2572      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2573      &   iprev,6600+irecv,FG_COMM,status,IERR)
2574 c        write (iout,*) "Gather PRECOMP12"
2575 c        call flush(iout)
2576         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2577      &  then
2578         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2579      &   MPI_ROTAT2(lensend),inext,7700+isend,
2580      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2581      &   iprev,7700+irecv,FG_COMM,status,IERR)
2582 c        write (iout,*) "Gather PRECOMP21"
2583 c        call flush(iout)
2584         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2585      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2586      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2587      &   iprev,8800+irecv,FG_COMM,status,IERR)
2588 c        write (iout,*) "Gather PRECOMP22"
2589 c        call flush(iout)
2590         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2591      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2592      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2593      &   MPI_PRECOMP23(lenrecv),
2594      &   iprev,9900+irecv,FG_COMM,status,IERR)
2595 c        write (iout,*) "Gather PRECOMP23"
2596 c        call flush(iout)
2597         endif
2598         isend=irecv
2599         irecv=irecv-1
2600         if (irecv.lt.0) irecv=nfgtasks1-1
2601       enddo
2602 #endif
2603         time_gather=time_gather+MPI_Wtime()-time00
2604       endif
2605 #ifdef DEBUG
2606 c      if (fg_rank.eq.0) then
2607         write (iout,*) "Arrays UG and UGDER"
2608         do i=1,nres-1
2609           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2610      &     ((ug(l,k,i),l=1,2),k=1,2),
2611      &     ((ugder(l,k,i),l=1,2),k=1,2)
2612         enddo
2613         write (iout,*) "Arrays UG2 and UG2DER"
2614         do i=1,nres-1
2615           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2616      &     ((ug2(l,k,i),l=1,2),k=1,2),
2617      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2618         enddo
2619         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2620         do i=1,nres-1
2621           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2622      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2623      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2624         enddo
2625         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2626         do i=1,nres-1
2627           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2628      &     costab(i),sintab(i),costab2(i),sintab2(i)
2629         enddo
2630         write (iout,*) "Array MUDER"
2631         do i=1,nres-1
2632           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2633         enddo
2634 c      endif
2635 #endif
2636 #endif
2637 cd      do i=1,nres
2638 cd        iti = itortyp(itype(i))
2639 cd        write (iout,*) i
2640 cd        do j=1,2
2641 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2642 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2643 cd        enddo
2644 cd      enddo
2645       return
2646       end
2647 C--------------------------------------------------------------------------
2648       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2649 C
2650 C This subroutine calculates the average interaction energy and its gradient
2651 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2652 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2653 C The potential depends both on the distance of peptide-group centers and on
2654 C the orientation of the CA-CA virtual bonds.
2655 C
2656       implicit real*8 (a-h,o-z)
2657 #ifdef MPI
2658       include 'mpif.h'
2659 #endif
2660       include 'DIMENSIONS'
2661       include 'COMMON.CONTROL'
2662       include 'COMMON.SETUP'
2663       include 'COMMON.IOUNITS'
2664       include 'COMMON.GEO'
2665       include 'COMMON.VAR'
2666       include 'COMMON.LOCAL'
2667       include 'COMMON.CHAIN'
2668       include 'COMMON.DERIV'
2669       include 'COMMON.INTERACT'
2670       include 'COMMON.CONTACTS'
2671       include 'COMMON.TORSION'
2672       include 'COMMON.VECTORS'
2673       include 'COMMON.FFIELD'
2674       include 'COMMON.TIME1'
2675       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2676      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2677       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2678      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2679       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2680      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2681      &    num_conti,j1,j2
2682 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2683 #ifdef MOMENT
2684       double precision scal_el /1.0d0/
2685 #else
2686       double precision scal_el /0.5d0/
2687 #endif
2688 C 12/13/98
2689 C 13-go grudnia roku pamietnego...
2690       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2691      &                   0.0d0,1.0d0,0.0d0,
2692      &                   0.0d0,0.0d0,1.0d0/
2693 cd      write(iout,*) 'In EELEC'
2694 cd      do i=1,nloctyp
2695 cd        write(iout,*) 'Type',i
2696 cd        write(iout,*) 'B1',B1(:,i)
2697 cd        write(iout,*) 'B2',B2(:,i)
2698 cd        write(iout,*) 'CC',CC(:,:,i)
2699 cd        write(iout,*) 'DD',DD(:,:,i)
2700 cd        write(iout,*) 'EE',EE(:,:,i)
2701 cd      enddo
2702 cd      call check_vecgrad
2703 cd      stop
2704       if (icheckgrad.eq.1) then
2705         do i=1,nres-1
2706           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2707           do k=1,3
2708             dc_norm(k,i)=dc(k,i)*fac
2709           enddo
2710 c          write (iout,*) 'i',i,' fac',fac
2711         enddo
2712       endif
2713       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2714      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2715      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2716 c        call vec_and_deriv
2717 #ifdef TIMING
2718         time01=MPI_Wtime()
2719 #endif
2720         call set_matrices
2721 #ifdef TIMING
2722         time_mat=time_mat+MPI_Wtime()-time01
2723 #endif
2724       endif
2725 cd      do i=1,nres-1
2726 cd        write (iout,*) 'i=',i
2727 cd        do k=1,3
2728 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2729 cd        enddo
2730 cd        do k=1,3
2731 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2732 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2733 cd        enddo
2734 cd      enddo
2735       t_eelecij=0.0d0
2736       ees=0.0D0
2737       evdw1=0.0D0
2738       eel_loc=0.0d0
2739       eello_turn3=0.0d0
2740       eello_turn4=0.0d0
2741       ind=0
2742       do i=1,nres
2743         num_cont_hb(i)=0
2744       enddo
2745 cd      print '(a)','Enter EELEC'
2746 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2747       do i=1,nres
2748         gel_loc_loc(i)=0.0d0
2749         gcorr_loc(i)=0.0d0
2750       enddo
2751 c
2752 c
2753 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2754 C
2755 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2756 C
2757       do i=iturn3_start,iturn3_end
2758         if (itype(i).eq.21 .or. itype(i+1).eq.21
2759      &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21) cycle
2760         dxi=dc(1,i)
2761         dyi=dc(2,i)
2762         dzi=dc(3,i)
2763         dx_normi=dc_norm(1,i)
2764         dy_normi=dc_norm(2,i)
2765         dz_normi=dc_norm(3,i)
2766         xmedi=c(1,i)+0.5d0*dxi
2767         ymedi=c(2,i)+0.5d0*dyi
2768         zmedi=c(3,i)+0.5d0*dzi
2769         num_conti=0
2770         call eelecij(i,i+2,ees,evdw1,eel_loc)
2771         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2772         num_cont_hb(i)=num_conti
2773       enddo
2774       do i=iturn4_start,iturn4_end
2775         if (itype(i).eq.21 .or. itype(i+1).eq.21 .or.
2776 c-----> Probably bug; should also handle itype(i+2)
2777      &    .or. itype(i+3).eq.21
2778      &    .or. itype(i+4).eq.21) cycle
2779         dxi=dc(1,i)
2780         dyi=dc(2,i)
2781         dzi=dc(3,i)
2782         dx_normi=dc_norm(1,i)
2783         dy_normi=dc_norm(2,i)
2784         dz_normi=dc_norm(3,i)
2785         xmedi=c(1,i)+0.5d0*dxi
2786         ymedi=c(2,i)+0.5d0*dyi
2787         zmedi=c(3,i)+0.5d0*dzi
2788         num_conti=num_cont_hb(i)
2789         call eelecij(i,i+3,ees,evdw1,eel_loc)
2790         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.21)
2791      &   call eturn4(i,eello_turn4)
2792         num_cont_hb(i)=num_conti
2793       enddo   ! i
2794 c
2795 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2796 c
2797       do i=iatel_s,iatel_e
2798         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
2799         dxi=dc(1,i)
2800         dyi=dc(2,i)
2801         dzi=dc(3,i)
2802         dx_normi=dc_norm(1,i)
2803         dy_normi=dc_norm(2,i)
2804         dz_normi=dc_norm(3,i)
2805         xmedi=c(1,i)+0.5d0*dxi
2806         ymedi=c(2,i)+0.5d0*dyi
2807         zmedi=c(3,i)+0.5d0*dzi
2808 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2809         num_conti=num_cont_hb(i)
2810         do j=ielstart(i),ielend(i)
2811 c          write (iout,*) i,j,itype(i),itype(j)
2812           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
2813           call eelecij(i,j,ees,evdw1,eel_loc)
2814         enddo ! j
2815         num_cont_hb(i)=num_conti
2816       enddo   ! i
2817 c      write (iout,*) "Number of loop steps in EELEC:",ind
2818 cd      do i=1,nres
2819 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2820 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2821 cd      enddo
2822 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2823 ccc      eel_loc=eel_loc+eello_turn3
2824 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2825       return
2826       end
2827 C-------------------------------------------------------------------------------
2828       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2829       implicit real*8 (a-h,o-z)
2830       include 'DIMENSIONS'
2831 #ifdef MPI
2832       include "mpif.h"
2833 #endif
2834       include 'COMMON.CONTROL'
2835       include 'COMMON.IOUNITS'
2836       include 'COMMON.GEO'
2837       include 'COMMON.VAR'
2838       include 'COMMON.LOCAL'
2839       include 'COMMON.CHAIN'
2840       include 'COMMON.DERIV'
2841       include 'COMMON.INTERACT'
2842       include 'COMMON.CONTACTS'
2843       include 'COMMON.TORSION'
2844       include 'COMMON.VECTORS'
2845       include 'COMMON.FFIELD'
2846       include 'COMMON.TIME1'
2847       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2848      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2849       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2850      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2851       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2852      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2853      &    num_conti,j1,j2
2854 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2855 #ifdef MOMENT
2856       double precision scal_el /1.0d0/
2857 #else
2858       double precision scal_el /0.5d0/
2859 #endif
2860 C 12/13/98
2861 C 13-go grudnia roku pamietnego...
2862       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2863      &                   0.0d0,1.0d0,0.0d0,
2864      &                   0.0d0,0.0d0,1.0d0/
2865 c          time00=MPI_Wtime()
2866 cd      write (iout,*) "eelecij",i,j
2867 c          ind=ind+1
2868           iteli=itel(i)
2869           itelj=itel(j)
2870           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2871           aaa=app(iteli,itelj)
2872           bbb=bpp(iteli,itelj)
2873           ael6i=ael6(iteli,itelj)
2874           ael3i=ael3(iteli,itelj)
2875           dxj=dc(1,j)
2876           dyj=dc(2,j)
2877           dzj=dc(3,j)
2878           dx_normj=dc_norm(1,j)
2879           dy_normj=dc_norm(2,j)
2880           dz_normj=dc_norm(3,j)
2881           xj=c(1,j)+0.5D0*dxj-xmedi
2882           yj=c(2,j)+0.5D0*dyj-ymedi
2883           zj=c(3,j)+0.5D0*dzj-zmedi
2884           rij=xj*xj+yj*yj+zj*zj
2885           rrmij=1.0D0/rij
2886           rij=dsqrt(rij)
2887           rmij=1.0D0/rij
2888           r3ij=rrmij*rmij
2889           r6ij=r3ij*r3ij
2890           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2891           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2892           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2893           fac=cosa-3.0D0*cosb*cosg
2894           ev1=aaa*r6ij*r6ij
2895 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2896           if (j.eq.i+2) ev1=scal_el*ev1
2897           ev2=bbb*r6ij
2898           fac3=ael6i*r6ij
2899           fac4=ael3i*r3ij
2900           evdwij=ev1+ev2
2901           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2902           el2=fac4*fac
2903           eesij=el1+el2
2904 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2905           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2906           ees=ees+eesij
2907           evdw1=evdw1+evdwij
2908 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2909 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2910 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2911 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2912
2913           if (energy_dec) then
2914               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2915               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2916           endif
2917
2918 C
2919 C Calculate contributions to the Cartesian gradient.
2920 C
2921 #ifdef SPLITELE
2922           facvdw=-6*rrmij*(ev1+evdwij)
2923           facel=-3*rrmij*(el1+eesij)
2924           fac1=fac
2925           erij(1)=xj*rmij
2926           erij(2)=yj*rmij
2927           erij(3)=zj*rmij
2928 *
2929 * Radial derivatives. First process both termini of the fragment (i,j)
2930 *
2931           ggg(1)=facel*xj
2932           ggg(2)=facel*yj
2933           ggg(3)=facel*zj
2934 c          do k=1,3
2935 c            ghalf=0.5D0*ggg(k)
2936 c            gelc(k,i)=gelc(k,i)+ghalf
2937 c            gelc(k,j)=gelc(k,j)+ghalf
2938 c          enddo
2939 c 9/28/08 AL Gradient compotents will be summed only at the end
2940           do k=1,3
2941             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2942             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2943           enddo
2944 *
2945 * Loop over residues i+1 thru j-1.
2946 *
2947 cgrad          do k=i+1,j-1
2948 cgrad            do l=1,3
2949 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2950 cgrad            enddo
2951 cgrad          enddo
2952           ggg(1)=facvdw*xj
2953           ggg(2)=facvdw*yj
2954           ggg(3)=facvdw*zj
2955 c          do k=1,3
2956 c            ghalf=0.5D0*ggg(k)
2957 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2958 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2959 c          enddo
2960 c 9/28/08 AL Gradient compotents will be summed only at the end
2961           do k=1,3
2962             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2963             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2964           enddo
2965 *
2966 * Loop over residues i+1 thru j-1.
2967 *
2968 cgrad          do k=i+1,j-1
2969 cgrad            do l=1,3
2970 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2971 cgrad            enddo
2972 cgrad          enddo
2973 #else
2974           facvdw=ev1+evdwij
2975           facel=el1+eesij
2976           fac1=fac
2977           fac=-3*rrmij*(facvdw+facvdw+facel)
2978           erij(1)=xj*rmij
2979           erij(2)=yj*rmij
2980           erij(3)=zj*rmij
2981 *
2982 * Radial derivatives. First process both termini of the fragment (i,j)
2983 *
2984           ggg(1)=fac*xj
2985           ggg(2)=fac*yj
2986           ggg(3)=fac*zj
2987 c          do k=1,3
2988 c            ghalf=0.5D0*ggg(k)
2989 c            gelc(k,i)=gelc(k,i)+ghalf
2990 c            gelc(k,j)=gelc(k,j)+ghalf
2991 c          enddo
2992 c 9/28/08 AL Gradient compotents will be summed only at the end
2993           do k=1,3
2994             gelc_long(k,j)=gelc(k,j)+ggg(k)
2995             gelc_long(k,i)=gelc(k,i)-ggg(k)
2996           enddo
2997 *
2998 * Loop over residues i+1 thru j-1.
2999 *
3000 cgrad          do k=i+1,j-1
3001 cgrad            do l=1,3
3002 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3003 cgrad            enddo
3004 cgrad          enddo
3005 c 9/28/08 AL Gradient compotents will be summed only at the end
3006           ggg(1)=facvdw*xj
3007           ggg(2)=facvdw*yj
3008           ggg(3)=facvdw*zj
3009           do k=1,3
3010             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3011             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3012           enddo
3013 #endif
3014 *
3015 * Angular part
3016 *
3017           ecosa=2.0D0*fac3*fac1+fac4
3018           fac4=-3.0D0*fac4
3019           fac3=-6.0D0*fac3
3020           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3021           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3022           do k=1,3
3023             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3024             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3025           enddo
3026 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3027 cd   &          (dcosg(k),k=1,3)
3028           do k=1,3
3029             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3030           enddo
3031 c          do k=1,3
3032 c            ghalf=0.5D0*ggg(k)
3033 c            gelc(k,i)=gelc(k,i)+ghalf
3034 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3035 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3036 c            gelc(k,j)=gelc(k,j)+ghalf
3037 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3038 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3039 c          enddo
3040 cgrad          do k=i+1,j-1
3041 cgrad            do l=1,3
3042 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3043 cgrad            enddo
3044 cgrad          enddo
3045           do k=1,3
3046             gelc(k,i)=gelc(k,i)
3047      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3048      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3049             gelc(k,j)=gelc(k,j)
3050      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3051      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3052             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3053             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3054           enddo
3055           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3056      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3057      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3058 C
3059 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3060 C   energy of a peptide unit is assumed in the form of a second-order
3061 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3062 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3063 C   are computed for EVERY pair of non-contiguous peptide groups.
3064 C
3065           if (j.lt.nres-1) then
3066             j1=j+1
3067             j2=j-1
3068           else
3069             j1=j-1
3070             j2=j-2
3071           endif
3072           kkk=0
3073           do k=1,2
3074             do l=1,2
3075               kkk=kkk+1
3076               muij(kkk)=mu(k,i)*mu(l,j)
3077             enddo
3078           enddo
3079 cd         write (iout,*) 'EELEC: i',i,' j',j
3080 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3081 cd          write(iout,*) 'muij',muij
3082           ury=scalar(uy(1,i),erij)
3083           urz=scalar(uz(1,i),erij)
3084           vry=scalar(uy(1,j),erij)
3085           vrz=scalar(uz(1,j),erij)
3086           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3087           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3088           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3089           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3090           fac=dsqrt(-ael6i)*r3ij
3091           a22=a22*fac
3092           a23=a23*fac
3093           a32=a32*fac
3094           a33=a33*fac
3095 cd          write (iout,'(4i5,4f10.5)')
3096 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3097 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3098 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3099 cd     &      uy(:,j),uz(:,j)
3100 cd          write (iout,'(4f10.5)')
3101 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3102 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3103 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3104 cd           write (iout,'(9f10.5/)')
3105 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3106 C Derivatives of the elements of A in virtual-bond vectors
3107           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3108           do k=1,3
3109             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3110             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3111             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3112             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3113             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3114             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3115             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3116             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3117             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3118             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3119             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3120             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3121           enddo
3122 C Compute radial contributions to the gradient
3123           facr=-3.0d0*rrmij
3124           a22der=a22*facr
3125           a23der=a23*facr
3126           a32der=a32*facr
3127           a33der=a33*facr
3128           agg(1,1)=a22der*xj
3129           agg(2,1)=a22der*yj
3130           agg(3,1)=a22der*zj
3131           agg(1,2)=a23der*xj
3132           agg(2,2)=a23der*yj
3133           agg(3,2)=a23der*zj
3134           agg(1,3)=a32der*xj
3135           agg(2,3)=a32der*yj
3136           agg(3,3)=a32der*zj
3137           agg(1,4)=a33der*xj
3138           agg(2,4)=a33der*yj
3139           agg(3,4)=a33der*zj
3140 C Add the contributions coming from er
3141           fac3=-3.0d0*fac
3142           do k=1,3
3143             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3144             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3145             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3146             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3147           enddo
3148           do k=1,3
3149 C Derivatives in DC(i)
3150 cgrad            ghalf1=0.5d0*agg(k,1)
3151 cgrad            ghalf2=0.5d0*agg(k,2)
3152 cgrad            ghalf3=0.5d0*agg(k,3)
3153 cgrad            ghalf4=0.5d0*agg(k,4)
3154             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3155      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3156             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3157      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3158             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3159      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3160             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3161      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3162 C Derivatives in DC(i+1)
3163             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3164      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3165             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3166      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3167             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3168      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3169             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3170      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3171 C Derivatives in DC(j)
3172             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3173      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3174             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3175      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3176             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3177      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3178             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3179      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3180 C Derivatives in DC(j+1) or DC(nres-1)
3181             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3182      &      -3.0d0*vryg(k,3)*ury)
3183             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3184      &      -3.0d0*vrzg(k,3)*ury)
3185             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3186      &      -3.0d0*vryg(k,3)*urz)
3187             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3188      &      -3.0d0*vrzg(k,3)*urz)
3189 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3190 cgrad              do l=1,4
3191 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3192 cgrad              enddo
3193 cgrad            endif
3194           enddo
3195           acipa(1,1)=a22
3196           acipa(1,2)=a23
3197           acipa(2,1)=a32
3198           acipa(2,2)=a33
3199           a22=-a22
3200           a23=-a23
3201           do l=1,2
3202             do k=1,3
3203               agg(k,l)=-agg(k,l)
3204               aggi(k,l)=-aggi(k,l)
3205               aggi1(k,l)=-aggi1(k,l)
3206               aggj(k,l)=-aggj(k,l)
3207               aggj1(k,l)=-aggj1(k,l)
3208             enddo
3209           enddo
3210           if (j.lt.nres-1) then
3211             a22=-a22
3212             a32=-a32
3213             do l=1,3,2
3214               do k=1,3
3215                 agg(k,l)=-agg(k,l)
3216                 aggi(k,l)=-aggi(k,l)
3217                 aggi1(k,l)=-aggi1(k,l)
3218                 aggj(k,l)=-aggj(k,l)
3219                 aggj1(k,l)=-aggj1(k,l)
3220               enddo
3221             enddo
3222           else
3223             a22=-a22
3224             a23=-a23
3225             a32=-a32
3226             a33=-a33
3227             do l=1,4
3228               do k=1,3
3229                 agg(k,l)=-agg(k,l)
3230                 aggi(k,l)=-aggi(k,l)
3231                 aggi1(k,l)=-aggi1(k,l)
3232                 aggj(k,l)=-aggj(k,l)
3233                 aggj1(k,l)=-aggj1(k,l)
3234               enddo
3235             enddo
3236           endif
3237           ENDIF ! WCORR
3238           IF (wel_loc.gt.0.0d0) THEN
3239 C Contribution to the local-electrostatic energy coming from the i-j pair
3240           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3241      &     +a33*muij(4)
3242 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3243
3244           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3245      &            'eelloc',i,j,eel_loc_ij
3246
3247           eel_loc=eel_loc+eel_loc_ij
3248 C Partial derivatives in virtual-bond dihedral angles gamma
3249           if (i.gt.1)
3250      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3251      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3252      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3253           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3254      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3255      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3256 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3257           do l=1,3
3258             ggg(l)=agg(l,1)*muij(1)+
3259      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3260             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3261             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3262 cgrad            ghalf=0.5d0*ggg(l)
3263 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3264 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3265           enddo
3266 cgrad          do k=i+1,j2
3267 cgrad            do l=1,3
3268 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3269 cgrad            enddo
3270 cgrad          enddo
3271 C Remaining derivatives of eello
3272           do l=1,3
3273             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3274      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3275             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3276      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3277             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3278      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3279             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3280      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3281           enddo
3282           ENDIF
3283 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3284 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3285           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3286      &       .and. num_conti.le.maxconts) then
3287 c            write (iout,*) i,j," entered corr"
3288 C
3289 C Calculate the contact function. The ith column of the array JCONT will
3290 C contain the numbers of atoms that make contacts with the atom I (of numbers
3291 C greater than I). The arrays FACONT and GACONT will contain the values of
3292 C the contact function and its derivative.
3293 c           r0ij=1.02D0*rpp(iteli,itelj)
3294 c           r0ij=1.11D0*rpp(iteli,itelj)
3295             r0ij=2.20D0*rpp(iteli,itelj)
3296 c           r0ij=1.55D0*rpp(iteli,itelj)
3297             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3298             if (fcont.gt.0.0D0) then
3299               num_conti=num_conti+1
3300               if (num_conti.gt.maxconts) then
3301                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3302      &                         ' will skip next contacts for this conf.'
3303               else
3304                 jcont_hb(num_conti,i)=j
3305 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3306 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3307                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3308      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3309 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3310 C  terms.
3311                 d_cont(num_conti,i)=rij
3312 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3313 C     --- Electrostatic-interaction matrix ---
3314                 a_chuj(1,1,num_conti,i)=a22
3315                 a_chuj(1,2,num_conti,i)=a23
3316                 a_chuj(2,1,num_conti,i)=a32
3317                 a_chuj(2,2,num_conti,i)=a33
3318 C     --- Gradient of rij
3319                 do kkk=1,3
3320                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3321                 enddo
3322                 kkll=0
3323                 do k=1,2
3324                   do l=1,2
3325                     kkll=kkll+1
3326                     do m=1,3
3327                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3328                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3329                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3330                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3331                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3332                     enddo
3333                   enddo
3334                 enddo
3335                 ENDIF
3336                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3337 C Calculate contact energies
3338                 cosa4=4.0D0*cosa
3339                 wij=cosa-3.0D0*cosb*cosg
3340                 cosbg1=cosb+cosg
3341                 cosbg2=cosb-cosg
3342 c               fac3=dsqrt(-ael6i)/r0ij**3
3343                 fac3=dsqrt(-ael6i)*r3ij
3344 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3345                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3346                 if (ees0tmp.gt.0) then
3347                   ees0pij=dsqrt(ees0tmp)
3348                 else
3349                   ees0pij=0
3350                 endif
3351 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3352                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3353                 if (ees0tmp.gt.0) then
3354                   ees0mij=dsqrt(ees0tmp)
3355                 else
3356                   ees0mij=0
3357                 endif
3358 c               ees0mij=0.0D0
3359                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3360                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3361 C Diagnostics. Comment out or remove after debugging!
3362 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3363 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3364 c               ees0m(num_conti,i)=0.0D0
3365 C End diagnostics.
3366 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3367 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3368 C Angular derivatives of the contact function
3369                 ees0pij1=fac3/ees0pij
3370                 ees0mij1=fac3/ees0mij
3371                 fac3p=-3.0D0*fac3*rrmij
3372                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3373                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3374 c               ees0mij1=0.0D0
3375                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3376                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3377                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3378                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3379                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3380                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3381                 ecosap=ecosa1+ecosa2
3382                 ecosbp=ecosb1+ecosb2
3383                 ecosgp=ecosg1+ecosg2
3384                 ecosam=ecosa1-ecosa2
3385                 ecosbm=ecosb1-ecosb2
3386                 ecosgm=ecosg1-ecosg2
3387 C Diagnostics
3388 c               ecosap=ecosa1
3389 c               ecosbp=ecosb1
3390 c               ecosgp=ecosg1
3391 c               ecosam=0.0D0
3392 c               ecosbm=0.0D0
3393 c               ecosgm=0.0D0
3394 C End diagnostics
3395                 facont_hb(num_conti,i)=fcont
3396                 fprimcont=fprimcont/rij
3397 cd              facont_hb(num_conti,i)=1.0D0
3398 C Following line is for diagnostics.
3399 cd              fprimcont=0.0D0
3400                 do k=1,3
3401                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3402                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3403                 enddo
3404                 do k=1,3
3405                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3406                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3407                 enddo
3408                 gggp(1)=gggp(1)+ees0pijp*xj
3409                 gggp(2)=gggp(2)+ees0pijp*yj
3410                 gggp(3)=gggp(3)+ees0pijp*zj
3411                 gggm(1)=gggm(1)+ees0mijp*xj
3412                 gggm(2)=gggm(2)+ees0mijp*yj
3413                 gggm(3)=gggm(3)+ees0mijp*zj
3414 C Derivatives due to the contact function
3415                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3416                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3417                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3418                 do k=1,3
3419 c
3420 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3421 c          following the change of gradient-summation algorithm.
3422 c
3423 cgrad                  ghalfp=0.5D0*gggp(k)
3424 cgrad                  ghalfm=0.5D0*gggm(k)
3425                   gacontp_hb1(k,num_conti,i)=!ghalfp
3426      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3427      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3428                   gacontp_hb2(k,num_conti,i)=!ghalfp
3429      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3430      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3431                   gacontp_hb3(k,num_conti,i)=gggp(k)
3432                   gacontm_hb1(k,num_conti,i)=!ghalfm
3433      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3434      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3435                   gacontm_hb2(k,num_conti,i)=!ghalfm
3436      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3437      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3438                   gacontm_hb3(k,num_conti,i)=gggm(k)
3439                 enddo
3440 C Diagnostics. Comment out or remove after debugging!
3441 cdiag           do k=1,3
3442 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3443 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3444 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3445 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3446 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3447 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3448 cdiag           enddo
3449               ENDIF ! wcorr
3450               endif  ! num_conti.le.maxconts
3451             endif  ! fcont.gt.0
3452           endif    ! j.gt.i+1
3453           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3454             do k=1,4
3455               do l=1,3
3456                 ghalf=0.5d0*agg(l,k)
3457                 aggi(l,k)=aggi(l,k)+ghalf
3458                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3459                 aggj(l,k)=aggj(l,k)+ghalf
3460               enddo
3461             enddo
3462             if (j.eq.nres-1 .and. i.lt.j-2) then
3463               do k=1,4
3464                 do l=1,3
3465                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3466                 enddo
3467               enddo
3468             endif
3469           endif
3470 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3471       return
3472       end
3473 C-----------------------------------------------------------------------------
3474       subroutine eturn3(i,eello_turn3)
3475 C Third- and fourth-order contributions from turns
3476       implicit real*8 (a-h,o-z)
3477       include 'DIMENSIONS'
3478       include 'COMMON.IOUNITS'
3479       include 'COMMON.GEO'
3480       include 'COMMON.VAR'
3481       include 'COMMON.LOCAL'
3482       include 'COMMON.CHAIN'
3483       include 'COMMON.DERIV'
3484       include 'COMMON.INTERACT'
3485       include 'COMMON.CONTACTS'
3486       include 'COMMON.TORSION'
3487       include 'COMMON.VECTORS'
3488       include 'COMMON.FFIELD'
3489       include 'COMMON.CONTROL'
3490       dimension ggg(3)
3491       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3492      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3493      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3494       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3495      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3496       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3497      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3498      &    num_conti,j1,j2
3499       j=i+2
3500 c      write (iout,*) "eturn3",i,j,j1,j2
3501       a_temp(1,1)=a22
3502       a_temp(1,2)=a23
3503       a_temp(2,1)=a32
3504       a_temp(2,2)=a33
3505 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3506 C
3507 C               Third-order contributions
3508 C
3509 C                 (i+2)o----(i+3)
3510 C                      | |
3511 C                      | |
3512 C                 (i+1)o----i
3513 C
3514 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3515 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3516         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3517         call transpose2(auxmat(1,1),auxmat1(1,1))
3518         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3519         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3520         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3521      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3522 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3523 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3524 cd     &    ' eello_turn3_num',4*eello_turn3_num
3525 C Derivatives in gamma(i)
3526         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3527         call transpose2(auxmat2(1,1),auxmat3(1,1))
3528         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3529         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3530 C Derivatives in gamma(i+1)
3531         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3532         call transpose2(auxmat2(1,1),auxmat3(1,1))
3533         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3534         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3535      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3536 C Cartesian derivatives
3537         do l=1,3
3538 c            ghalf1=0.5d0*agg(l,1)
3539 c            ghalf2=0.5d0*agg(l,2)
3540 c            ghalf3=0.5d0*agg(l,3)
3541 c            ghalf4=0.5d0*agg(l,4)
3542           a_temp(1,1)=aggi(l,1)!+ghalf1
3543           a_temp(1,2)=aggi(l,2)!+ghalf2
3544           a_temp(2,1)=aggi(l,3)!+ghalf3
3545           a_temp(2,2)=aggi(l,4)!+ghalf4
3546           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3547           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3548      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3549           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3550           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3551           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3552           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3553           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3554           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3555      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3556           a_temp(1,1)=aggj(l,1)!+ghalf1
3557           a_temp(1,2)=aggj(l,2)!+ghalf2
3558           a_temp(2,1)=aggj(l,3)!+ghalf3
3559           a_temp(2,2)=aggj(l,4)!+ghalf4
3560           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3561           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3562      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3563           a_temp(1,1)=aggj1(l,1)
3564           a_temp(1,2)=aggj1(l,2)
3565           a_temp(2,1)=aggj1(l,3)
3566           a_temp(2,2)=aggj1(l,4)
3567           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3568           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3569      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3570         enddo
3571       return
3572       end
3573 C-------------------------------------------------------------------------------
3574       subroutine eturn4(i,eello_turn4)
3575 C Third- and fourth-order contributions from turns
3576       implicit real*8 (a-h,o-z)
3577       include 'DIMENSIONS'
3578       include 'COMMON.IOUNITS'
3579       include 'COMMON.GEO'
3580       include 'COMMON.VAR'
3581       include 'COMMON.LOCAL'
3582       include 'COMMON.CHAIN'
3583       include 'COMMON.DERIV'
3584       include 'COMMON.INTERACT'
3585       include 'COMMON.CONTACTS'
3586       include 'COMMON.TORSION'
3587       include 'COMMON.VECTORS'
3588       include 'COMMON.FFIELD'
3589       include 'COMMON.CONTROL'
3590       dimension ggg(3)
3591       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3592      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3593      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3594       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3595      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3596       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3597      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3598      &    num_conti,j1,j2
3599       j=i+3
3600 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3601 C
3602 C               Fourth-order contributions
3603 C
3604 C                 (i+3)o----(i+4)
3605 C                     /  |
3606 C               (i+2)o   |
3607 C                     \  |
3608 C                 (i+1)o----i
3609 C
3610 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3611 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3612 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3613         a_temp(1,1)=a22
3614         a_temp(1,2)=a23
3615         a_temp(2,1)=a32
3616         a_temp(2,2)=a33
3617         iti1=itortyp(itype(i+1))
3618         iti2=itortyp(itype(i+2))
3619         iti3=itortyp(itype(i+3))
3620 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3621         call transpose2(EUg(1,1,i+1),e1t(1,1))
3622         call transpose2(Eug(1,1,i+2),e2t(1,1))
3623         call transpose2(Eug(1,1,i+3),e3t(1,1))
3624         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3625         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3626         s1=scalar2(b1(1,iti2),auxvec(1))
3627         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3628         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3629         s2=scalar2(b1(1,iti1),auxvec(1))
3630         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3631         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3632         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3633         eello_turn4=eello_turn4-(s1+s2+s3)
3634         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3635      &      'eturn4',i,j,-(s1+s2+s3)
3636 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3637 cd     &    ' eello_turn4_num',8*eello_turn4_num
3638 C Derivatives in gamma(i)
3639         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3640         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3641         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3642         s1=scalar2(b1(1,iti2),auxvec(1))
3643         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3644         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3645         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3646 C Derivatives in gamma(i+1)
3647         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3648         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3649         s2=scalar2(b1(1,iti1),auxvec(1))
3650         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3651         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3652         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3653         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3654 C Derivatives in gamma(i+2)
3655         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3656         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3657         s1=scalar2(b1(1,iti2),auxvec(1))
3658         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3659         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3660         s2=scalar2(b1(1,iti1),auxvec(1))
3661         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3662         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3663         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3664         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3665 C Cartesian derivatives
3666 C Derivatives of this turn contributions in DC(i+2)
3667         if (j.lt.nres-1) then
3668           do l=1,3
3669             a_temp(1,1)=agg(l,1)
3670             a_temp(1,2)=agg(l,2)
3671             a_temp(2,1)=agg(l,3)
3672             a_temp(2,2)=agg(l,4)
3673             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3674             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3675             s1=scalar2(b1(1,iti2),auxvec(1))
3676             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3677             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3678             s2=scalar2(b1(1,iti1),auxvec(1))
3679             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3680             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3681             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3682             ggg(l)=-(s1+s2+s3)
3683             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3684           enddo
3685         endif
3686 C Remaining derivatives of this turn contribution
3687         do l=1,3
3688           a_temp(1,1)=aggi(l,1)
3689           a_temp(1,2)=aggi(l,2)
3690           a_temp(2,1)=aggi(l,3)
3691           a_temp(2,2)=aggi(l,4)
3692           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3693           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3694           s1=scalar2(b1(1,iti2),auxvec(1))
3695           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3696           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3697           s2=scalar2(b1(1,iti1),auxvec(1))
3698           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3699           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3700           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3701           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3702           a_temp(1,1)=aggi1(l,1)
3703           a_temp(1,2)=aggi1(l,2)
3704           a_temp(2,1)=aggi1(l,3)
3705           a_temp(2,2)=aggi1(l,4)
3706           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3707           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3708           s1=scalar2(b1(1,iti2),auxvec(1))
3709           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3710           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3711           s2=scalar2(b1(1,iti1),auxvec(1))
3712           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3713           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3714           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3715           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3716           a_temp(1,1)=aggj(l,1)
3717           a_temp(1,2)=aggj(l,2)
3718           a_temp(2,1)=aggj(l,3)
3719           a_temp(2,2)=aggj(l,4)
3720           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3721           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3722           s1=scalar2(b1(1,iti2),auxvec(1))
3723           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3724           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3725           s2=scalar2(b1(1,iti1),auxvec(1))
3726           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3727           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3728           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3729           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3730           a_temp(1,1)=aggj1(l,1)
3731           a_temp(1,2)=aggj1(l,2)
3732           a_temp(2,1)=aggj1(l,3)
3733           a_temp(2,2)=aggj1(l,4)
3734           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3735           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3736           s1=scalar2(b1(1,iti2),auxvec(1))
3737           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3738           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3739           s2=scalar2(b1(1,iti1),auxvec(1))
3740           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3741           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3742           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3743 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3744           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3745         enddo
3746       return
3747       end
3748 C-----------------------------------------------------------------------------
3749       subroutine vecpr(u,v,w)
3750       implicit real*8(a-h,o-z)
3751       dimension u(3),v(3),w(3)
3752       w(1)=u(2)*v(3)-u(3)*v(2)
3753       w(2)=-u(1)*v(3)+u(3)*v(1)
3754       w(3)=u(1)*v(2)-u(2)*v(1)
3755       return
3756       end
3757 C-----------------------------------------------------------------------------
3758       subroutine unormderiv(u,ugrad,unorm,ungrad)
3759 C This subroutine computes the derivatives of a normalized vector u, given
3760 C the derivatives computed without normalization conditions, ugrad. Returns
3761 C ungrad.
3762       implicit none
3763       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3764       double precision vec(3)
3765       double precision scalar
3766       integer i,j
3767 c      write (2,*) 'ugrad',ugrad
3768 c      write (2,*) 'u',u
3769       do i=1,3
3770         vec(i)=scalar(ugrad(1,i),u(1))
3771       enddo
3772 c      write (2,*) 'vec',vec
3773       do i=1,3
3774         do j=1,3
3775           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3776         enddo
3777       enddo
3778 c      write (2,*) 'ungrad',ungrad
3779       return
3780       end
3781 C-----------------------------------------------------------------------------
3782       subroutine escp_soft_sphere(evdw2,evdw2_14)
3783 C
3784 C This subroutine calculates the excluded-volume interaction energy between
3785 C peptide-group centers and side chains and its gradient in virtual-bond and
3786 C side-chain vectors.
3787 C
3788       implicit real*8 (a-h,o-z)
3789       include 'DIMENSIONS'
3790       include 'COMMON.GEO'
3791       include 'COMMON.VAR'
3792       include 'COMMON.LOCAL'
3793       include 'COMMON.CHAIN'
3794       include 'COMMON.DERIV'
3795       include 'COMMON.INTERACT'
3796       include 'COMMON.FFIELD'
3797       include 'COMMON.IOUNITS'
3798       include 'COMMON.CONTROL'
3799       dimension ggg(3)
3800       evdw2=0.0D0
3801       evdw2_14=0.0d0
3802       r0_scp=4.5d0
3803 cd    print '(a)','Enter ESCP'
3804 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3805       do i=iatscp_s,iatscp_e
3806         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3807         iteli=itel(i)
3808         xi=0.5D0*(c(1,i)+c(1,i+1))
3809         yi=0.5D0*(c(2,i)+c(2,i+1))
3810         zi=0.5D0*(c(3,i)+c(3,i+1))
3811
3812         do iint=1,nscp_gr(i)
3813
3814         do j=iscpstart(i,iint),iscpend(i,iint)
3815           if (itype(j).eq.21) cycle
3816           itypj=itype(j)
3817 C Uncomment following three lines for SC-p interactions
3818 c         xj=c(1,nres+j)-xi
3819 c         yj=c(2,nres+j)-yi
3820 c         zj=c(3,nres+j)-zi
3821 C Uncomment following three lines for Ca-p interactions
3822           xj=c(1,j)-xi
3823           yj=c(2,j)-yi
3824           zj=c(3,j)-zi
3825           rij=xj*xj+yj*yj+zj*zj
3826           r0ij=r0_scp
3827           r0ijsq=r0ij*r0ij
3828           if (rij.lt.r0ijsq) then
3829             evdwij=0.25d0*(rij-r0ijsq)**2
3830             fac=rij-r0ijsq
3831           else
3832             evdwij=0.0d0
3833             fac=0.0d0
3834           endif
3835           evdw2=evdw2+evdwij
3836 C
3837 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3838 C
3839           ggg(1)=xj*fac
3840           ggg(2)=yj*fac
3841           ggg(3)=zj*fac
3842 cgrad          if (j.lt.i) then
3843 cd          write (iout,*) 'j<i'
3844 C Uncomment following three lines for SC-p interactions
3845 c           do k=1,3
3846 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3847 c           enddo
3848 cgrad          else
3849 cd          write (iout,*) 'j>i'
3850 cgrad            do k=1,3
3851 cgrad              ggg(k)=-ggg(k)
3852 C Uncomment following line for SC-p interactions
3853 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3854 cgrad            enddo
3855 cgrad          endif
3856 cgrad          do k=1,3
3857 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3858 cgrad          enddo
3859 cgrad          kstart=min0(i+1,j)
3860 cgrad          kend=max0(i-1,j-1)
3861 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3862 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3863 cgrad          do k=kstart,kend
3864 cgrad            do l=1,3
3865 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3866 cgrad            enddo
3867 cgrad          enddo
3868           do k=1,3
3869             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3870             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3871           enddo
3872         enddo
3873
3874         enddo ! iint
3875       enddo ! i
3876       return
3877       end
3878 C-----------------------------------------------------------------------------
3879       subroutine escp(evdw2,evdw2_14)
3880 C
3881 C This subroutine calculates the excluded-volume interaction energy between
3882 C peptide-group centers and side chains and its gradient in virtual-bond and
3883 C side-chain vectors.
3884 C
3885       implicit real*8 (a-h,o-z)
3886       include 'DIMENSIONS'
3887       include 'COMMON.GEO'
3888       include 'COMMON.VAR'
3889       include 'COMMON.LOCAL'
3890       include 'COMMON.CHAIN'
3891       include 'COMMON.DERIV'
3892       include 'COMMON.INTERACT'
3893       include 'COMMON.FFIELD'
3894       include 'COMMON.IOUNITS'
3895       include 'COMMON.CONTROL'
3896       dimension ggg(3)
3897       evdw2=0.0D0
3898       evdw2_14=0.0d0
3899 cd    print '(a)','Enter ESCP'
3900 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3901       do i=iatscp_s,iatscp_e
3902         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3903         iteli=itel(i)
3904         xi=0.5D0*(c(1,i)+c(1,i+1))
3905         yi=0.5D0*(c(2,i)+c(2,i+1))
3906         zi=0.5D0*(c(3,i)+c(3,i+1))
3907
3908         do iint=1,nscp_gr(i)
3909
3910         do j=iscpstart(i,iint),iscpend(i,iint)
3911           itypj=itype(j)
3912           if (itypj.eq.21) cycle
3913 C Uncomment following three lines for SC-p interactions
3914 c         xj=c(1,nres+j)-xi
3915 c         yj=c(2,nres+j)-yi
3916 c         zj=c(3,nres+j)-zi
3917 C Uncomment following three lines for Ca-p interactions
3918           xj=c(1,j)-xi
3919           yj=c(2,j)-yi
3920           zj=c(3,j)-zi
3921           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3922           fac=rrij**expon2
3923           e1=fac*fac*aad(itypj,iteli)
3924           e2=fac*bad(itypj,iteli)
3925           if (iabs(j-i) .le. 2) then
3926             e1=scal14*e1
3927             e2=scal14*e2
3928             evdw2_14=evdw2_14+e1+e2
3929           endif
3930           evdwij=e1+e2
3931           evdw2=evdw2+evdwij
3932           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3933      &        'evdw2',i,j,evdwij
3934 C
3935 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3936 C
3937           fac=-(evdwij+e1)*rrij
3938           ggg(1)=xj*fac
3939           ggg(2)=yj*fac
3940           ggg(3)=zj*fac
3941 cgrad          if (j.lt.i) then
3942 cd          write (iout,*) 'j<i'
3943 C Uncomment following three lines for SC-p interactions
3944 c           do k=1,3
3945 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3946 c           enddo
3947 cgrad          else
3948 cd          write (iout,*) 'j>i'
3949 cgrad            do k=1,3
3950 cgrad              ggg(k)=-ggg(k)
3951 C Uncomment following line for SC-p interactions
3952 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3953 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3954 cgrad            enddo
3955 cgrad          endif
3956 cgrad          do k=1,3
3957 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3958 cgrad          enddo
3959 cgrad          kstart=min0(i+1,j)
3960 cgrad          kend=max0(i-1,j-1)
3961 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3962 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3963 cgrad          do k=kstart,kend
3964 cgrad            do l=1,3
3965 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3966 cgrad            enddo
3967 cgrad          enddo
3968           do k=1,3
3969             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3970             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3971           enddo
3972         enddo
3973
3974         enddo ! iint
3975       enddo ! i
3976       do i=1,nct
3977         do j=1,3
3978           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3979           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
3980           gradx_scp(j,i)=expon*gradx_scp(j,i)
3981         enddo
3982       enddo
3983 C******************************************************************************
3984 C
3985 C                              N O T E !!!
3986 C
3987 C To save time the factor EXPON has been extracted from ALL components
3988 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3989 C use!
3990 C
3991 C******************************************************************************
3992       return
3993       end
3994 C--------------------------------------------------------------------------
3995       subroutine edis(ehpb)
3996 C
3997 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3998 C
3999       implicit real*8 (a-h,o-z)
4000       include 'DIMENSIONS'
4001       include 'COMMON.SBRIDGE'
4002       include 'COMMON.CHAIN'
4003       include 'COMMON.DERIV'
4004       include 'COMMON.VAR'
4005       include 'COMMON.INTERACT'
4006       include 'COMMON.IOUNITS'
4007       dimension ggg(3)
4008       ehpb=0.0D0
4009 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4010 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4011       if (link_end.eq.0) return
4012       do i=link_start,link_end
4013 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4014 C CA-CA distance used in regularization of structure.
4015         ii=ihpb(i)
4016         jj=jhpb(i)
4017 C iii and jjj point to the residues for which the distance is assigned.
4018         if (ii.gt.nres) then
4019           iii=ii-nres
4020           jjj=jj-nres
4021         else
4022           iii=ii
4023           jjj=jj
4024         endif
4025 cd        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj
4026 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4027 C    distance and angle dependent SS bond potential.
4028         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4029           call ssbond_ene(iii,jjj,eij)
4030           ehpb=ehpb+2*eij
4031 cd          write (iout,*) "eij",eij
4032         else
4033 C Calculate the distance between the two points and its difference from the
4034 C target distance.
4035         dd=dist(ii,jj)
4036         rdis=dd-dhpb(i)
4037 C Get the force constant corresponding to this distance.
4038         waga=forcon(i)
4039 C Calculate the contribution to energy.
4040         ehpb=ehpb+waga*rdis*rdis
4041 C
4042 C Evaluate gradient.
4043 C
4044         fac=waga*rdis/dd
4045 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4046 cd   &   ' waga=',waga,' fac=',fac
4047         do j=1,3
4048           ggg(j)=fac*(c(j,jj)-c(j,ii))
4049         enddo
4050 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4051 C If this is a SC-SC distance, we need to calculate the contributions to the
4052 C Cartesian gradient in the SC vectors (ghpbx).
4053         if (iii.lt.ii) then
4054           do j=1,3
4055             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4056             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4057           enddo
4058         endif
4059 cgrad        do j=iii,jjj-1
4060 cgrad          do k=1,3
4061 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4062 cgrad          enddo
4063 cgrad        enddo
4064         do k=1,3
4065           ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4066           ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4067         enddo
4068         endif
4069       enddo
4070       ehpb=0.5D0*ehpb
4071       return
4072       end
4073 C--------------------------------------------------------------------------
4074       subroutine ssbond_ene(i,j,eij)
4075 C
4076 C Calculate the distance and angle dependent SS-bond potential energy
4077 C using a free-energy function derived based on RHF/6-31G** ab initio
4078 C calculations of diethyl disulfide.
4079 C
4080 C A. Liwo and U. Kozlowska, 11/24/03
4081 C
4082       implicit real*8 (a-h,o-z)
4083       include 'DIMENSIONS'
4084       include 'COMMON.SBRIDGE'
4085       include 'COMMON.CHAIN'
4086       include 'COMMON.DERIV'
4087       include 'COMMON.LOCAL'
4088       include 'COMMON.INTERACT'
4089       include 'COMMON.VAR'
4090       include 'COMMON.IOUNITS'
4091       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4092       itypi=itype(i)
4093       xi=c(1,nres+i)
4094       yi=c(2,nres+i)
4095       zi=c(3,nres+i)
4096       dxi=dc_norm(1,nres+i)
4097       dyi=dc_norm(2,nres+i)
4098       dzi=dc_norm(3,nres+i)
4099 c      dsci_inv=dsc_inv(itypi)
4100       dsci_inv=vbld_inv(nres+i)
4101       itypj=itype(j)
4102 c      dscj_inv=dsc_inv(itypj)
4103       dscj_inv=vbld_inv(nres+j)
4104       xj=c(1,nres+j)-xi
4105       yj=c(2,nres+j)-yi
4106       zj=c(3,nres+j)-zi
4107       dxj=dc_norm(1,nres+j)
4108       dyj=dc_norm(2,nres+j)
4109       dzj=dc_norm(3,nres+j)
4110       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4111       rij=dsqrt(rrij)
4112       erij(1)=xj*rij
4113       erij(2)=yj*rij
4114       erij(3)=zj*rij
4115       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4116       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4117       om12=dxi*dxj+dyi*dyj+dzi*dzj
4118       do k=1,3
4119         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4120         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4121       enddo
4122       rij=1.0d0/rij
4123       deltad=rij-d0cm
4124       deltat1=1.0d0-om1
4125       deltat2=1.0d0+om2
4126       deltat12=om2-om1+2.0d0
4127       cosphi=om12-om1*om2
4128       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4129      &  +akct*deltad*deltat12
4130      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4131 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4132 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4133 c     &  " deltat12",deltat12," eij",eij
4134       ed=2*akcm*deltad+akct*deltat12
4135       pom1=akct*deltad
4136       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4137       eom1=-2*akth*deltat1-pom1-om2*pom2
4138       eom2= 2*akth*deltat2+pom1-om1*pom2
4139       eom12=pom2
4140       do k=1,3
4141         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4142         ghpbx(k,i)=ghpbx(k,i)-ggk
4143      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4144      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4145         ghpbx(k,j)=ghpbx(k,j)+ggk
4146      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4147      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4148         ghpbc(k,i)=ghpbc(k,i)-ggk
4149         ghpbc(k,j)=ghpbc(k,j)+ggk
4150       enddo
4151 C
4152 C Calculate the components of the gradient in DC and X
4153 C
4154 cgrad      do k=i,j-1
4155 cgrad        do l=1,3
4156 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4157 cgrad        enddo
4158 cgrad      enddo
4159       return
4160       end
4161 C--------------------------------------------------------------------------
4162       subroutine ebond(estr)
4163 c
4164 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4165 c
4166       implicit real*8 (a-h,o-z)
4167       include 'DIMENSIONS'
4168       include 'COMMON.LOCAL'
4169       include 'COMMON.GEO'
4170       include 'COMMON.INTERACT'
4171       include 'COMMON.DERIV'
4172       include 'COMMON.VAR'
4173       include 'COMMON.CHAIN'
4174       include 'COMMON.IOUNITS'
4175       include 'COMMON.NAMES'
4176       include 'COMMON.FFIELD'
4177       include 'COMMON.CONTROL'
4178       include 'COMMON.SETUP'
4179       double precision u(3),ud(3)
4180       estr=0.0d0
4181       estr1=0.0d0
4182       do i=ibondp_start,ibondp_end
4183         if (itype(i-1).eq.21 .or. itype(i).eq.21) then
4184           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4185           do j=1,3
4186           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4187      &      *dc(j,i-1)/vbld(i)
4188           enddo
4189           if (energy_dec) write(iout,*)
4190      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4191         else
4192         diff = vbld(i)-vbldp0
4193         if (energy_dec) write (iout,*)
4194      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4195         estr=estr+diff*diff
4196         do j=1,3
4197           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4198         enddo
4199 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4200         endif
4201       enddo
4202       estr=0.5d0*AKP*estr+estr1
4203 c
4204 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4205 c
4206       do i=ibond_start,ibond_end
4207         iti=itype(i)
4208         if (iti.ne.10 .and. iti.ne.21) then
4209           nbi=nbondterm(iti)
4210           if (nbi.eq.1) then
4211             diff=vbld(i+nres)-vbldsc0(1,iti)
4212             if (energy_dec) write (iout,*)
4213      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4214      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4215             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4216             do j=1,3
4217               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4218             enddo
4219           else
4220             do j=1,nbi
4221               diff=vbld(i+nres)-vbldsc0(j,iti)
4222               ud(j)=aksc(j,iti)*diff
4223               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4224             enddo
4225             uprod=u(1)
4226             do j=2,nbi
4227               uprod=uprod*u(j)
4228             enddo
4229             usum=0.0d0
4230             usumsqder=0.0d0
4231             do j=1,nbi
4232               uprod1=1.0d0
4233               uprod2=1.0d0
4234               do k=1,nbi
4235                 if (k.ne.j) then
4236                   uprod1=uprod1*u(k)
4237                   uprod2=uprod2*u(k)*u(k)
4238                 endif
4239               enddo
4240               usum=usum+uprod1
4241               usumsqder=usumsqder+ud(j)*uprod2
4242             enddo
4243             estr=estr+uprod/usum
4244             do j=1,3
4245              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4246             enddo
4247           endif
4248         endif
4249       enddo
4250       return
4251       end
4252 #ifdef CRYST_THETA
4253 C--------------------------------------------------------------------------
4254       subroutine ebend(etheta)
4255 C
4256 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4257 C angles gamma and its derivatives in consecutive thetas and gammas.
4258 C
4259       implicit real*8 (a-h,o-z)
4260       include 'DIMENSIONS'
4261       include 'COMMON.LOCAL'
4262       include 'COMMON.GEO'
4263       include 'COMMON.INTERACT'
4264       include 'COMMON.DERIV'
4265       include 'COMMON.VAR'
4266       include 'COMMON.CHAIN'
4267       include 'COMMON.IOUNITS'
4268       include 'COMMON.NAMES'
4269       include 'COMMON.FFIELD'
4270       include 'COMMON.CONTROL'
4271       common /calcthet/ term1,term2,termm,diffak,ratak,
4272      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4273      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4274       double precision y(2),z(2)
4275       delta=0.02d0*pi
4276 c      time11=dexp(-2*time)
4277 c      time12=1.0d0
4278       etheta=0.0D0
4279 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4280       do i=ithet_start,ithet_end
4281         if (itype(i-1).eq.21) cycle
4282 C Zero the energy function and its derivative at 0 or pi.
4283         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4284         it=itype(i-1)
4285         if (i.gt.3 .and. itype(i-2).ne.21) then
4286 #ifdef OSF
4287           phii=phi(i)
4288           if (phii.ne.phii) phii=150.0
4289 #else
4290           phii=phi(i)
4291 #endif
4292           y(1)=dcos(phii)
4293           y(2)=dsin(phii)
4294         else
4295           y(1)=0.0D0
4296           y(2)=0.0D0
4297         endif
4298         if (i.lt.nres .and. itype(i).ne.21) then
4299 #ifdef OSF
4300           phii1=phi(i+1)
4301           if (phii1.ne.phii1) phii1=150.0
4302           phii1=pinorm(phii1)
4303           z(1)=cos(phii1)
4304 #else
4305           phii1=phi(i+1)
4306           z(1)=dcos(phii1)
4307 #endif
4308           z(2)=dsin(phii1)
4309         else
4310           z(1)=0.0D0
4311           z(2)=0.0D0
4312         endif
4313 C Calculate the "mean" value of theta from the part of the distribution
4314 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4315 C In following comments this theta will be referred to as t_c.
4316         thet_pred_mean=0.0d0
4317         do k=1,2
4318           athetk=athet(k,it)
4319           bthetk=bthet(k,it)
4320           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4321         enddo
4322         dthett=thet_pred_mean*ssd
4323         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4324 C Derivatives of the "mean" values in gamma1 and gamma2.
4325         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4326         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4327         if (theta(i).gt.pi-delta) then
4328           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4329      &         E_tc0)
4330           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4331           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4332           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4333      &        E_theta)
4334           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4335      &        E_tc)
4336         else if (theta(i).lt.delta) then
4337           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4338           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4339           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4340      &        E_theta)
4341           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4342           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4343      &        E_tc)
4344         else
4345           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4346      &        E_theta,E_tc)
4347         endif
4348         etheta=etheta+ethetai
4349         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4350      &      'ebend',i,ethetai
4351         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4352         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4353         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4354       enddo
4355 C Ufff.... We've done all this!!!
4356       return
4357       end
4358 C---------------------------------------------------------------------------
4359       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4360      &     E_tc)
4361       implicit real*8 (a-h,o-z)
4362       include 'DIMENSIONS'
4363       include 'COMMON.LOCAL'
4364       include 'COMMON.IOUNITS'
4365       common /calcthet/ term1,term2,termm,diffak,ratak,
4366      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4367      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4368 C Calculate the contributions to both Gaussian lobes.
4369 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4370 C The "polynomial part" of the "standard deviation" of this part of
4371 C the distribution.
4372         sig=polthet(3,it)
4373         do j=2,0,-1
4374           sig=sig*thet_pred_mean+polthet(j,it)
4375         enddo
4376 C Derivative of the "interior part" of the "standard deviation of the"
4377 C gamma-dependent Gaussian lobe in t_c.
4378         sigtc=3*polthet(3,it)
4379         do j=2,1,-1
4380           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4381         enddo
4382         sigtc=sig*sigtc
4383 C Set the parameters of both Gaussian lobes of the distribution.
4384 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4385         fac=sig*sig+sigc0(it)
4386         sigcsq=fac+fac
4387         sigc=1.0D0/sigcsq
4388 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4389         sigsqtc=-4.0D0*sigcsq*sigtc
4390 c       print *,i,sig,sigtc,sigsqtc
4391 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4392         sigtc=-sigtc/(fac*fac)
4393 C Following variable is sigma(t_c)**(-2)
4394         sigcsq=sigcsq*sigcsq
4395         sig0i=sig0(it)
4396         sig0inv=1.0D0/sig0i**2
4397         delthec=thetai-thet_pred_mean
4398         delthe0=thetai-theta0i
4399         term1=-0.5D0*sigcsq*delthec*delthec
4400         term2=-0.5D0*sig0inv*delthe0*delthe0
4401 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4402 C NaNs in taking the logarithm. We extract the largest exponent which is added
4403 C to the energy (this being the log of the distribution) at the end of energy
4404 C term evaluation for this virtual-bond angle.
4405         if (term1.gt.term2) then
4406           termm=term1
4407           term2=dexp(term2-termm)
4408           term1=1.0d0
4409         else
4410           termm=term2
4411           term1=dexp(term1-termm)
4412           term2=1.0d0
4413         endif
4414 C The ratio between the gamma-independent and gamma-dependent lobes of
4415 C the distribution is a Gaussian function of thet_pred_mean too.
4416         diffak=gthet(2,it)-thet_pred_mean
4417         ratak=diffak/gthet(3,it)**2
4418         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4419 C Let's differentiate it in thet_pred_mean NOW.
4420         aktc=ak*ratak
4421 C Now put together the distribution terms to make complete distribution.
4422         termexp=term1+ak*term2
4423         termpre=sigc+ak*sig0i
4424 C Contribution of the bending energy from this theta is just the -log of
4425 C the sum of the contributions from the two lobes and the pre-exponential
4426 C factor. Simple enough, isn't it?
4427         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4428 C NOW the derivatives!!!
4429 C 6/6/97 Take into account the deformation.
4430         E_theta=(delthec*sigcsq*term1
4431      &       +ak*delthe0*sig0inv*term2)/termexp
4432         E_tc=((sigtc+aktc*sig0i)/termpre
4433      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4434      &       aktc*term2)/termexp)
4435       return
4436       end
4437 c-----------------------------------------------------------------------------
4438       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4439       implicit real*8 (a-h,o-z)
4440       include 'DIMENSIONS'
4441       include 'COMMON.LOCAL'
4442       include 'COMMON.IOUNITS'
4443       common /calcthet/ term1,term2,termm,diffak,ratak,
4444      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4445      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4446       delthec=thetai-thet_pred_mean
4447       delthe0=thetai-theta0i
4448 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4449       t3 = thetai-thet_pred_mean
4450       t6 = t3**2
4451       t9 = term1
4452       t12 = t3*sigcsq
4453       t14 = t12+t6*sigsqtc
4454       t16 = 1.0d0
4455       t21 = thetai-theta0i
4456       t23 = t21**2
4457       t26 = term2
4458       t27 = t21*t26
4459       t32 = termexp
4460       t40 = t32**2
4461       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4462      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4463      & *(-t12*t9-ak*sig0inv*t27)
4464       return
4465       end
4466 #else
4467 C--------------------------------------------------------------------------
4468       subroutine ebend(etheta)
4469 C
4470 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4471 C angles gamma and its derivatives in consecutive thetas and gammas.
4472 C ab initio-derived potentials from
4473 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4474 C
4475       implicit real*8 (a-h,o-z)
4476       include 'DIMENSIONS'
4477       include 'COMMON.LOCAL'
4478       include 'COMMON.GEO'
4479       include 'COMMON.INTERACT'
4480       include 'COMMON.DERIV'
4481       include 'COMMON.VAR'
4482       include 'COMMON.CHAIN'
4483       include 'COMMON.IOUNITS'
4484       include 'COMMON.NAMES'
4485       include 'COMMON.FFIELD'
4486       include 'COMMON.CONTROL'
4487       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4488      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4489      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4490      & sinph1ph2(maxdouble,maxdouble)
4491       logical lprn /.false./, lprn1 /.false./
4492       etheta=0.0D0
4493       do i=ithet_start,ithet_end
4494         if (itype(i-1).eq.21) cycle
4495         dethetai=0.0d0
4496         dephii=0.0d0
4497         dephii1=0.0d0
4498         theti2=0.5d0*theta(i)
4499         ityp2=ithetyp(itype(i-1))
4500         do k=1,nntheterm
4501           coskt(k)=dcos(k*theti2)
4502           sinkt(k)=dsin(k*theti2)
4503         enddo
4504         if (i.gt.3 .and. itype(i-2).ne.21) then
4505 #ifdef OSF
4506           phii=phi(i)
4507           if (phii.ne.phii) phii=150.0
4508 #else
4509           phii=phi(i)
4510 #endif
4511           ityp1=ithetyp(itype(i-2))
4512           do k=1,nsingle
4513             cosph1(k)=dcos(k*phii)
4514             sinph1(k)=dsin(k*phii)
4515           enddo
4516         else
4517           phii=0.0d0
4518           ityp1=nthetyp+1
4519           do k=1,nsingle
4520             cosph1(k)=0.0d0
4521             sinph1(k)=0.0d0
4522           enddo
4523         endif
4524         if (i.lt.nres .and. itype(i).ne.21) then
4525 #ifdef OSF
4526           phii1=phi(i+1)
4527           if (phii1.ne.phii1) phii1=150.0
4528           phii1=pinorm(phii1)
4529 #else
4530           phii1=phi(i+1)
4531 #endif
4532           ityp3=ithetyp(itype(i))
4533           do k=1,nsingle
4534             cosph2(k)=dcos(k*phii1)
4535             sinph2(k)=dsin(k*phii1)
4536           enddo
4537         else
4538           phii1=0.0d0
4539           ityp3=nthetyp+1
4540           do k=1,nsingle
4541             cosph2(k)=0.0d0
4542             sinph2(k)=0.0d0
4543           enddo
4544         endif
4545         ethetai=aa0thet(ityp1,ityp2,ityp3)
4546         do k=1,ndouble
4547           do l=1,k-1
4548             ccl=cosph1(l)*cosph2(k-l)
4549             ssl=sinph1(l)*sinph2(k-l)
4550             scl=sinph1(l)*cosph2(k-l)
4551             csl=cosph1(l)*sinph2(k-l)
4552             cosph1ph2(l,k)=ccl-ssl
4553             cosph1ph2(k,l)=ccl+ssl
4554             sinph1ph2(l,k)=scl+csl
4555             sinph1ph2(k,l)=scl-csl
4556           enddo
4557         enddo
4558         if (lprn) then
4559         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4560      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4561         write (iout,*) "coskt and sinkt"
4562         do k=1,nntheterm
4563           write (iout,*) k,coskt(k),sinkt(k)
4564         enddo
4565         endif
4566         do k=1,ntheterm
4567           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4568           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4569      &      *coskt(k)
4570           if (lprn)
4571      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4572      &     " ethetai",ethetai
4573         enddo
4574         if (lprn) then
4575         write (iout,*) "cosph and sinph"
4576         do k=1,nsingle
4577           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4578         enddo
4579         write (iout,*) "cosph1ph2 and sinph2ph2"
4580         do k=2,ndouble
4581           do l=1,k-1
4582             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4583      &         sinph1ph2(l,k),sinph1ph2(k,l)
4584           enddo
4585         enddo
4586         write(iout,*) "ethetai",ethetai
4587         endif
4588         do m=1,ntheterm2
4589           do k=1,nsingle
4590             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4591      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4592      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4593      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4594             ethetai=ethetai+sinkt(m)*aux
4595             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4596             dephii=dephii+k*sinkt(m)*(
4597      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4598      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4599             dephii1=dephii1+k*sinkt(m)*(
4600      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4601      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4602             if (lprn)
4603      &      write (iout,*) "m",m," k",k," bbthet",
4604      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4605      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4606      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4607      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4608           enddo
4609         enddo
4610         if (lprn)
4611      &  write(iout,*) "ethetai",ethetai
4612         do m=1,ntheterm3
4613           do k=2,ndouble
4614             do l=1,k-1
4615               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4616      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4617      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4618      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4619               ethetai=ethetai+sinkt(m)*aux
4620               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4621               dephii=dephii+l*sinkt(m)*(
4622      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4623      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4624      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4625      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4626               dephii1=dephii1+(k-l)*sinkt(m)*(
4627      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4628      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4629      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4630      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4631               if (lprn) then
4632               write (iout,*) "m",m," k",k," l",l," ffthet",
4633      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4634      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4635      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4636      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4637               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4638      &            cosph1ph2(k,l)*sinkt(m),
4639      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4640               endif
4641             enddo
4642           enddo
4643         enddo
4644 10      continue
4645         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4646      &   i,theta(i)*rad2deg,phii*rad2deg,
4647      &   phii1*rad2deg,ethetai
4648         etheta=etheta+ethetai
4649         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4650         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4651         gloc(nphi+i-2,icg)=wang*dethetai
4652       enddo
4653       return
4654       end
4655 #endif
4656 #ifdef CRYST_SC
4657 c-----------------------------------------------------------------------------
4658       subroutine esc(escloc)
4659 C Calculate the local energy of a side chain and its derivatives in the
4660 C corresponding virtual-bond valence angles THETA and the spherical angles
4661 C ALPHA and OMEGA.
4662       implicit real*8 (a-h,o-z)
4663       include 'DIMENSIONS'
4664       include 'COMMON.GEO'
4665       include 'COMMON.LOCAL'
4666       include 'COMMON.VAR'
4667       include 'COMMON.INTERACT'
4668       include 'COMMON.DERIV'
4669       include 'COMMON.CHAIN'
4670       include 'COMMON.IOUNITS'
4671       include 'COMMON.NAMES'
4672       include 'COMMON.FFIELD'
4673       include 'COMMON.CONTROL'
4674       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4675      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4676       common /sccalc/ time11,time12,time112,theti,it,nlobit
4677       delta=0.02d0*pi
4678       escloc=0.0D0
4679 c     write (iout,'(a)') 'ESC'
4680       do i=loc_start,loc_end
4681         it=itype(i)
4682         if (it.eq.21) cycle
4683         if (it.eq.10) goto 1
4684         nlobit=nlob(it)
4685 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4686 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4687         theti=theta(i+1)-pipol
4688         x(1)=dtan(theti)
4689         x(2)=alph(i)
4690         x(3)=omeg(i)
4691
4692         if (x(2).gt.pi-delta) then
4693           xtemp(1)=x(1)
4694           xtemp(2)=pi-delta
4695           xtemp(3)=x(3)
4696           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4697           xtemp(2)=pi
4698           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4699           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4700      &        escloci,dersc(2))
4701           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4702      &        ddersc0(1),dersc(1))
4703           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4704      &        ddersc0(3),dersc(3))
4705           xtemp(2)=pi-delta
4706           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4707           xtemp(2)=pi
4708           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4709           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4710      &            dersc0(2),esclocbi,dersc02)
4711           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4712      &            dersc12,dersc01)
4713           call splinthet(x(2),0.5d0*delta,ss,ssd)
4714           dersc0(1)=dersc01
4715           dersc0(2)=dersc02
4716           dersc0(3)=0.0d0
4717           do k=1,3
4718             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4719           enddo
4720           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4721 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4722 c    &             esclocbi,ss,ssd
4723           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4724 c         escloci=esclocbi
4725 c         write (iout,*) escloci
4726         else if (x(2).lt.delta) then
4727           xtemp(1)=x(1)
4728           xtemp(2)=delta
4729           xtemp(3)=x(3)
4730           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4731           xtemp(2)=0.0d0
4732           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4733           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4734      &        escloci,dersc(2))
4735           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4736      &        ddersc0(1),dersc(1))
4737           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4738      &        ddersc0(3),dersc(3))
4739           xtemp(2)=delta
4740           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4741           xtemp(2)=0.0d0
4742           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4743           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4744      &            dersc0(2),esclocbi,dersc02)
4745           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4746      &            dersc12,dersc01)
4747           dersc0(1)=dersc01
4748           dersc0(2)=dersc02
4749           dersc0(3)=0.0d0
4750           call splinthet(x(2),0.5d0*delta,ss,ssd)
4751           do k=1,3
4752             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4753           enddo
4754           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4755 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4756 c    &             esclocbi,ss,ssd
4757           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4758 c         write (iout,*) escloci
4759         else
4760           call enesc(x,escloci,dersc,ddummy,.false.)
4761         endif
4762
4763         escloc=escloc+escloci
4764         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4765      &     'escloc',i,escloci
4766 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4767
4768         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4769      &   wscloc*dersc(1)
4770         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4771         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4772     1   continue
4773       enddo
4774       return
4775       end
4776 C---------------------------------------------------------------------------
4777       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4778       implicit real*8 (a-h,o-z)
4779       include 'DIMENSIONS'
4780       include 'COMMON.GEO'
4781       include 'COMMON.LOCAL'
4782       include 'COMMON.IOUNITS'
4783       common /sccalc/ time11,time12,time112,theti,it,nlobit
4784       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4785       double precision contr(maxlob,-1:1)
4786       logical mixed
4787 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4788         escloc_i=0.0D0
4789         do j=1,3
4790           dersc(j)=0.0D0
4791           if (mixed) ddersc(j)=0.0d0
4792         enddo
4793         x3=x(3)
4794
4795 C Because of periodicity of the dependence of the SC energy in omega we have
4796 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4797 C To avoid underflows, first compute & store the exponents.
4798
4799         do iii=-1,1
4800
4801           x(3)=x3+iii*dwapi
4802
4803           do j=1,nlobit
4804             do k=1,3
4805               z(k)=x(k)-censc(k,j,it)
4806             enddo
4807             do k=1,3
4808               Axk=0.0D0
4809               do l=1,3
4810                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4811               enddo
4812               Ax(k,j,iii)=Axk
4813             enddo
4814             expfac=0.0D0
4815             do k=1,3
4816               expfac=expfac+Ax(k,j,iii)*z(k)
4817             enddo
4818             contr(j,iii)=expfac
4819           enddo ! j
4820
4821         enddo ! iii
4822
4823         x(3)=x3
4824 C As in the case of ebend, we want to avoid underflows in exponentiation and
4825 C subsequent NaNs and INFs in energy calculation.
4826 C Find the largest exponent
4827         emin=contr(1,-1)
4828         do iii=-1,1
4829           do j=1,nlobit
4830             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4831           enddo
4832         enddo
4833         emin=0.5D0*emin
4834 cd      print *,'it=',it,' emin=',emin
4835
4836 C Compute the contribution to SC energy and derivatives
4837         do iii=-1,1
4838
4839           do j=1,nlobit
4840 #ifdef OSF
4841             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4842             if(adexp.ne.adexp) adexp=1.0
4843             expfac=dexp(adexp)
4844 #else
4845             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4846 #endif
4847 cd          print *,'j=',j,' expfac=',expfac
4848             escloc_i=escloc_i+expfac
4849             do k=1,3
4850               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4851             enddo
4852             if (mixed) then
4853               do k=1,3,2
4854                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4855      &            +gaussc(k,2,j,it))*expfac
4856               enddo
4857             endif
4858           enddo
4859
4860         enddo ! iii
4861
4862         dersc(1)=dersc(1)/cos(theti)**2
4863         ddersc(1)=ddersc(1)/cos(theti)**2
4864         ddersc(3)=ddersc(3)
4865
4866         escloci=-(dlog(escloc_i)-emin)
4867         do j=1,3
4868           dersc(j)=dersc(j)/escloc_i
4869         enddo
4870         if (mixed) then
4871           do j=1,3,2
4872             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4873           enddo
4874         endif
4875       return
4876       end
4877 C------------------------------------------------------------------------------
4878       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4879       implicit real*8 (a-h,o-z)
4880       include 'DIMENSIONS'
4881       include 'COMMON.GEO'
4882       include 'COMMON.LOCAL'
4883       include 'COMMON.IOUNITS'
4884       common /sccalc/ time11,time12,time112,theti,it,nlobit
4885       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4886       double precision contr(maxlob)
4887       logical mixed
4888
4889       escloc_i=0.0D0
4890
4891       do j=1,3
4892         dersc(j)=0.0D0
4893       enddo
4894
4895       do j=1,nlobit
4896         do k=1,2
4897           z(k)=x(k)-censc(k,j,it)
4898         enddo
4899         z(3)=dwapi
4900         do k=1,3
4901           Axk=0.0D0
4902           do l=1,3
4903             Axk=Axk+gaussc(l,k,j,it)*z(l)
4904           enddo
4905           Ax(k,j)=Axk
4906         enddo
4907         expfac=0.0D0
4908         do k=1,3
4909           expfac=expfac+Ax(k,j)*z(k)
4910         enddo
4911         contr(j)=expfac
4912       enddo ! j
4913
4914 C As in the case of ebend, we want to avoid underflows in exponentiation and
4915 C subsequent NaNs and INFs in energy calculation.
4916 C Find the largest exponent
4917       emin=contr(1)
4918       do j=1,nlobit
4919         if (emin.gt.contr(j)) emin=contr(j)
4920       enddo
4921       emin=0.5D0*emin
4922
4923 C Compute the contribution to SC energy and derivatives
4924
4925       dersc12=0.0d0
4926       do j=1,nlobit
4927         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4928         escloc_i=escloc_i+expfac
4929         do k=1,2
4930           dersc(k)=dersc(k)+Ax(k,j)*expfac
4931         enddo
4932         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4933      &            +gaussc(1,2,j,it))*expfac
4934         dersc(3)=0.0d0
4935       enddo
4936
4937       dersc(1)=dersc(1)/cos(theti)**2
4938       dersc12=dersc12/cos(theti)**2
4939       escloci=-(dlog(escloc_i)-emin)
4940       do j=1,2
4941         dersc(j)=dersc(j)/escloc_i
4942       enddo
4943       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4944       return
4945       end
4946 #else
4947 c----------------------------------------------------------------------------------
4948       subroutine esc(escloc)
4949 C Calculate the local energy of a side chain and its derivatives in the
4950 C corresponding virtual-bond valence angles THETA and the spherical angles
4951 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4952 C added by Urszula Kozlowska. 07/11/2007
4953 C
4954       implicit real*8 (a-h,o-z)
4955       include 'DIMENSIONS'
4956       include 'COMMON.GEO'
4957       include 'COMMON.LOCAL'
4958       include 'COMMON.VAR'
4959       include 'COMMON.SCROT'
4960       include 'COMMON.INTERACT'
4961       include 'COMMON.DERIV'
4962       include 'COMMON.CHAIN'
4963       include 'COMMON.IOUNITS'
4964       include 'COMMON.NAMES'
4965       include 'COMMON.FFIELD'
4966       include 'COMMON.CONTROL'
4967       include 'COMMON.VECTORS'
4968       double precision x_prime(3),y_prime(3),z_prime(3)
4969      &    , sumene,dsc_i,dp2_i,x(65),
4970      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4971      &    de_dxx,de_dyy,de_dzz,de_dt
4972       double precision s1_t,s1_6_t,s2_t,s2_6_t
4973       double precision
4974      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4975      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4976      & dt_dCi(3),dt_dCi1(3)
4977       common /sccalc/ time11,time12,time112,theti,it,nlobit
4978       delta=0.02d0*pi
4979       escloc=0.0D0
4980       do i=loc_start,loc_end
4981         if (itype(i).eq.21) cycle
4982         costtab(i+1) =dcos(theta(i+1))
4983         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4984         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4985         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4986         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4987         cosfac=dsqrt(cosfac2)
4988         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4989         sinfac=dsqrt(sinfac2)
4990         it=itype(i)
4991         if (it.eq.10) goto 1
4992 c
4993 C  Compute the axes of tghe local cartesian coordinates system; store in
4994 c   x_prime, y_prime and z_prime
4995 c
4996         do j=1,3
4997           x_prime(j) = 0.00
4998           y_prime(j) = 0.00
4999           z_prime(j) = 0.00
5000         enddo
5001 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5002 C     &   dc_norm(3,i+nres)
5003         do j = 1,3
5004           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5005           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5006         enddo
5007         do j = 1,3
5008           z_prime(j) = -uz(j,i-1)
5009         enddo
5010 c       write (2,*) "i",i
5011 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5012 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5013 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5014 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5015 c      & " xy",scalar(x_prime(1),y_prime(1)),
5016 c      & " xz",scalar(x_prime(1),z_prime(1)),
5017 c      & " yy",scalar(y_prime(1),y_prime(1)),
5018 c      & " yz",scalar(y_prime(1),z_prime(1)),
5019 c      & " zz",scalar(z_prime(1),z_prime(1))
5020 c
5021 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5022 C to local coordinate system. Store in xx, yy, zz.
5023 c
5024         xx=0.0d0
5025         yy=0.0d0
5026         zz=0.0d0
5027         do j = 1,3
5028           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5029           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5030           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5031         enddo
5032
5033         xxtab(i)=xx
5034         yytab(i)=yy
5035         zztab(i)=zz
5036 C
5037 C Compute the energy of the ith side cbain
5038 C
5039 c        write (2,*) "xx",xx," yy",yy," zz",zz
5040         it=itype(i)
5041         do j = 1,65
5042           x(j) = sc_parmin(j,it)
5043         enddo
5044 #ifdef CHECK_COORD
5045 Cc diagnostics - remove later
5046         xx1 = dcos(alph(2))
5047         yy1 = dsin(alph(2))*dcos(omeg(2))
5048         zz1 = -dsin(alph(2))*dsin(omeg(2))
5049         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5050      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5051      &    xx1,yy1,zz1
5052 C,"  --- ", xx_w,yy_w,zz_w
5053 c end diagnostics
5054 #endif
5055         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5056      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5057      &   + x(10)*yy*zz
5058         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5059      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5060      & + x(20)*yy*zz
5061         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5062      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5063      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5064      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5065      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5066      &  +x(40)*xx*yy*zz
5067         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5068      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5069      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5070      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5071      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5072      &  +x(60)*xx*yy*zz
5073         dsc_i   = 0.743d0+x(61)
5074         dp2_i   = 1.9d0+x(62)
5075         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5076      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5077         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5078      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5079         s1=(1+x(63))/(0.1d0 + dscp1)
5080         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5081         s2=(1+x(65))/(0.1d0 + dscp2)
5082         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5083         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5084      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5085 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5086 c     &   sumene4,
5087 c     &   dscp1,dscp2,sumene
5088 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5089         escloc = escloc + sumene
5090 c        write (2,*) "i",i," escloc",sumene,escloc
5091 #ifdef DEBUG
5092 C
5093 C This section to check the numerical derivatives of the energy of ith side
5094 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5095 C #define DEBUG in the code to turn it on.
5096 C
5097         write (2,*) "sumene               =",sumene
5098         aincr=1.0d-7
5099         xxsave=xx
5100         xx=xx+aincr
5101         write (2,*) xx,yy,zz
5102         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5103         de_dxx_num=(sumenep-sumene)/aincr
5104         xx=xxsave
5105         write (2,*) "xx+ sumene from enesc=",sumenep
5106         yysave=yy
5107         yy=yy+aincr
5108         write (2,*) xx,yy,zz
5109         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5110         de_dyy_num=(sumenep-sumene)/aincr
5111         yy=yysave
5112         write (2,*) "yy+ sumene from enesc=",sumenep
5113         zzsave=zz
5114         zz=zz+aincr
5115         write (2,*) xx,yy,zz
5116         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5117         de_dzz_num=(sumenep-sumene)/aincr
5118         zz=zzsave
5119         write (2,*) "zz+ sumene from enesc=",sumenep
5120         costsave=cost2tab(i+1)
5121         sintsave=sint2tab(i+1)
5122         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5123         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5124         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5125         de_dt_num=(sumenep-sumene)/aincr
5126         write (2,*) " t+ sumene from enesc=",sumenep
5127         cost2tab(i+1)=costsave
5128         sint2tab(i+1)=sintsave
5129 C End of diagnostics section.
5130 #endif
5131 C
5132 C Compute the gradient of esc
5133 C
5134         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5135         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5136         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5137         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5138         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5139         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5140         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5141         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5142         pom1=(sumene3*sint2tab(i+1)+sumene1)
5143      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5144         pom2=(sumene4*cost2tab(i+1)+sumene2)
5145      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5146         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5147         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5148      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5149      &  +x(40)*yy*zz
5150         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5151         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5152      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5153      &  +x(60)*yy*zz
5154         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5155      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5156      &        +(pom1+pom2)*pom_dx
5157 #ifdef DEBUG
5158         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5159 #endif
5160 C
5161         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5162         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5163      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5164      &  +x(40)*xx*zz
5165         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5166         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5167      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5168      &  +x(59)*zz**2 +x(60)*xx*zz
5169         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5170      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5171      &        +(pom1-pom2)*pom_dy
5172 #ifdef DEBUG
5173         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5174 #endif
5175 C
5176         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5177      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5178      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5179      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5180      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5181      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5182      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5183      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5184 #ifdef DEBUG
5185         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5186 #endif
5187 C
5188         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5189      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5190      &  +pom1*pom_dt1+pom2*pom_dt2
5191 #ifdef DEBUG
5192         write(2,*), "de_dt = ", de_dt,de_dt_num
5193 #endif
5194 c
5195 C
5196        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5197        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5198        cosfac2xx=cosfac2*xx
5199        sinfac2yy=sinfac2*yy
5200        do k = 1,3
5201          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5202      &      vbld_inv(i+1)
5203          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5204      &      vbld_inv(i)
5205          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5206          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5207 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5208 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5209 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5210 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5211          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5212          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5213          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5214          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5215          dZZ_Ci1(k)=0.0d0
5216          dZZ_Ci(k)=0.0d0
5217          do j=1,3
5218            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5219            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5220          enddo
5221
5222          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5223          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5224          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5225 c
5226          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5227          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5228        enddo
5229
5230        do k=1,3
5231          dXX_Ctab(k,i)=dXX_Ci(k)
5232          dXX_C1tab(k,i)=dXX_Ci1(k)
5233          dYY_Ctab(k,i)=dYY_Ci(k)
5234          dYY_C1tab(k,i)=dYY_Ci1(k)
5235          dZZ_Ctab(k,i)=dZZ_Ci(k)
5236          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5237          dXX_XYZtab(k,i)=dXX_XYZ(k)
5238          dYY_XYZtab(k,i)=dYY_XYZ(k)
5239          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5240        enddo
5241
5242        do k = 1,3
5243 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5244 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5245 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5246 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5247 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5248 c     &    dt_dci(k)
5249 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5250 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5251          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5252      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5253          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5254      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5255          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5256      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5257        enddo
5258 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5259 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5260
5261 C to check gradient call subroutine check_grad
5262
5263     1 continue
5264       enddo
5265       return
5266       end
5267 c------------------------------------------------------------------------------
5268       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5269       implicit none
5270       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5271      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5272       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5273      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5274      &   + x(10)*yy*zz
5275       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5276      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5277      & + x(20)*yy*zz
5278       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5279      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5280      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5281      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5282      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5283      &  +x(40)*xx*yy*zz
5284       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5285      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5286      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5287      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5288      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5289      &  +x(60)*xx*yy*zz
5290       dsc_i   = 0.743d0+x(61)
5291       dp2_i   = 1.9d0+x(62)
5292       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5293      &          *(xx*cost2+yy*sint2))
5294       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5295      &          *(xx*cost2-yy*sint2))
5296       s1=(1+x(63))/(0.1d0 + dscp1)
5297       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5298       s2=(1+x(65))/(0.1d0 + dscp2)
5299       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5300       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5301      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5302       enesc=sumene
5303       return
5304       end
5305 #endif
5306 c------------------------------------------------------------------------------
5307       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5308 C
5309 C This procedure calculates two-body contact function g(rij) and its derivative:
5310 C
5311 C           eps0ij                                     !       x < -1
5312 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5313 C            0                                         !       x > 1
5314 C
5315 C where x=(rij-r0ij)/delta
5316 C
5317 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5318 C
5319       implicit none
5320       double precision rij,r0ij,eps0ij,fcont,fprimcont
5321       double precision x,x2,x4,delta
5322 c     delta=0.02D0*r0ij
5323 c      delta=0.2D0*r0ij
5324       x=(rij-r0ij)/delta
5325       if (x.lt.-1.0D0) then
5326         fcont=eps0ij
5327         fprimcont=0.0D0
5328       else if (x.le.1.0D0) then
5329         x2=x*x
5330         x4=x2*x2
5331         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5332         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5333       else
5334         fcont=0.0D0
5335         fprimcont=0.0D0
5336       endif
5337       return
5338       end
5339 c------------------------------------------------------------------------------
5340       subroutine splinthet(theti,delta,ss,ssder)
5341       implicit real*8 (a-h,o-z)
5342       include 'DIMENSIONS'
5343       include 'COMMON.VAR'
5344       include 'COMMON.GEO'
5345       thetup=pi-delta
5346       thetlow=delta
5347       if (theti.gt.pipol) then
5348         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5349       else
5350         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5351         ssder=-ssder
5352       endif
5353       return
5354       end
5355 c------------------------------------------------------------------------------
5356       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5357       implicit none
5358       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5359       double precision ksi,ksi2,ksi3,a1,a2,a3
5360       a1=fprim0*delta/(f1-f0)
5361       a2=3.0d0-2.0d0*a1
5362       a3=a1-2.0d0
5363       ksi=(x-x0)/delta
5364       ksi2=ksi*ksi
5365       ksi3=ksi2*ksi
5366       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5367       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5368       return
5369       end
5370 c------------------------------------------------------------------------------
5371       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5372       implicit none
5373       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5374       double precision ksi,ksi2,ksi3,a1,a2,a3
5375       ksi=(x-x0)/delta
5376       ksi2=ksi*ksi
5377       ksi3=ksi2*ksi
5378       a1=fprim0x*delta
5379       a2=3*(f1x-f0x)-2*fprim0x*delta
5380       a3=fprim0x*delta-2*(f1x-f0x)
5381       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5382       return
5383       end
5384 C-----------------------------------------------------------------------------
5385 #ifdef CRYST_TOR
5386 C-----------------------------------------------------------------------------
5387       subroutine etor(etors,edihcnstr)
5388       implicit real*8 (a-h,o-z)
5389       include 'DIMENSIONS'
5390       include 'COMMON.VAR'
5391       include 'COMMON.GEO'
5392       include 'COMMON.LOCAL'
5393       include 'COMMON.TORSION'
5394       include 'COMMON.INTERACT'
5395       include 'COMMON.DERIV'
5396       include 'COMMON.CHAIN'
5397       include 'COMMON.NAMES'
5398       include 'COMMON.IOUNITS'
5399       include 'COMMON.FFIELD'
5400       include 'COMMON.TORCNSTR'
5401       include 'COMMON.CONTROL'
5402       logical lprn
5403 C Set lprn=.true. for debugging
5404       lprn=.false.
5405 c      lprn=.true.
5406       etors=0.0D0
5407       do i=iphi_start,iphi_end
5408       etors_ii=0.0D0
5409         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5410      &      .or. itype(i).eq.21) cycle
5411         itori=itortyp(itype(i-2))
5412         itori1=itortyp(itype(i-1))
5413         phii=phi(i)
5414         gloci=0.0D0
5415 C Proline-Proline pair is a special case...
5416         if (itori.eq.3 .and. itori1.eq.3) then
5417           if (phii.gt.-dwapi3) then
5418             cosphi=dcos(3*phii)
5419             fac=1.0D0/(1.0D0-cosphi)
5420             etorsi=v1(1,3,3)*fac
5421             etorsi=etorsi+etorsi
5422             etors=etors+etorsi-v1(1,3,3)
5423             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5424             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5425           endif
5426           do j=1,3
5427             v1ij=v1(j+1,itori,itori1)
5428             v2ij=v2(j+1,itori,itori1)
5429             cosphi=dcos(j*phii)
5430             sinphi=dsin(j*phii)
5431             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5432             if (energy_dec) etors_ii=etors_ii+
5433      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5434             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5435           enddo
5436         else
5437           do j=1,nterm_old
5438             v1ij=v1(j,itori,itori1)
5439             v2ij=v2(j,itori,itori1)
5440             cosphi=dcos(j*phii)
5441             sinphi=dsin(j*phii)
5442             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5443             if (energy_dec) etors_ii=etors_ii+
5444      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5445             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5446           enddo
5447         endif
5448         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5449              'etor',i,etors_ii
5450         if (lprn)
5451      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5452      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5453      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5454         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5455 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5456       enddo
5457 ! 6/20/98 - dihedral angle constraints
5458       edihcnstr=0.0d0
5459       do i=1,ndih_constr
5460         itori=idih_constr(i)
5461         phii=phi(itori)
5462         difi=phii-phi0(i)
5463         if (difi.gt.drange(i)) then
5464           difi=difi-drange(i)
5465           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5466           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5467         else if (difi.lt.-drange(i)) then
5468           difi=difi+drange(i)
5469           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5470           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5471         endif
5472 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5473 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5474       enddo
5475 !      write (iout,*) 'edihcnstr',edihcnstr
5476       return
5477       end
5478 c------------------------------------------------------------------------------
5479       subroutine etor_d(etors_d)
5480       etors_d=0.0d0
5481       return
5482       end
5483 c----------------------------------------------------------------------------
5484 #else
5485       subroutine etor(etors,edihcnstr)
5486       implicit real*8 (a-h,o-z)
5487       include 'DIMENSIONS'
5488       include 'COMMON.VAR'
5489       include 'COMMON.GEO'
5490       include 'COMMON.LOCAL'
5491       include 'COMMON.TORSION'
5492       include 'COMMON.INTERACT'
5493       include 'COMMON.DERIV'
5494       include 'COMMON.CHAIN'
5495       include 'COMMON.NAMES'
5496       include 'COMMON.IOUNITS'
5497       include 'COMMON.FFIELD'
5498       include 'COMMON.TORCNSTR'
5499       include 'COMMON.CONTROL'
5500       logical lprn
5501 C Set lprn=.true. for debugging
5502       lprn=.false.
5503 c     lprn=.true.
5504       etors=0.0D0
5505       do i=iphi_start,iphi_end
5506         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5507      &       .or. itype(i).eq.21) cycle
5508         etors_ii=0.0D0
5509         itori=itortyp(itype(i-2))
5510         itori1=itortyp(itype(i-1))
5511         phii=phi(i)
5512         gloci=0.0D0
5513 C Regular cosine and sine terms
5514         do j=1,nterm(itori,itori1)
5515           v1ij=v1(j,itori,itori1)
5516           v2ij=v2(j,itori,itori1)
5517           cosphi=dcos(j*phii)
5518           sinphi=dsin(j*phii)
5519           etors=etors+v1ij*cosphi+v2ij*sinphi
5520           if (energy_dec) etors_ii=etors_ii+
5521      &                v1ij*cosphi+v2ij*sinphi
5522           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5523         enddo
5524 C Lorentz terms
5525 C                         v1
5526 C  E = SUM ----------------------------------- - v1
5527 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5528 C
5529         cosphi=dcos(0.5d0*phii)
5530         sinphi=dsin(0.5d0*phii)
5531         do j=1,nlor(itori,itori1)
5532           vl1ij=vlor1(j,itori,itori1)
5533           vl2ij=vlor2(j,itori,itori1)
5534           vl3ij=vlor3(j,itori,itori1)
5535           pom=vl2ij*cosphi+vl3ij*sinphi
5536           pom1=1.0d0/(pom*pom+1.0d0)
5537           etors=etors+vl1ij*pom1
5538           if (energy_dec) etors_ii=etors_ii+
5539      &                vl1ij*pom1
5540           pom=-pom*pom1*pom1
5541           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5542         enddo
5543 C Subtract the constant term
5544         etors=etors-v0(itori,itori1)
5545           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5546      &         'etor',i,etors_ii-v0(itori,itori1)
5547         if (lprn)
5548      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5549      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5550      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5551         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5552 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5553       enddo
5554 ! 6/20/98 - dihedral angle constraints
5555       edihcnstr=0.0d0
5556 c      do i=1,ndih_constr
5557       do i=idihconstr_start,idihconstr_end
5558         itori=idih_constr(i)
5559         phii=phi(itori)
5560         difi=pinorm(phii-phi0(i))
5561         if (difi.gt.drange(i)) then
5562           difi=difi-drange(i)
5563           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5564           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5565         else if (difi.lt.-drange(i)) then
5566           difi=difi+drange(i)
5567           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5568           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5569         else
5570           difi=0.0
5571         endif
5572 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5573 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5574 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5575       enddo
5576 cd       write (iout,*) 'edihcnstr',edihcnstr
5577       return
5578       end
5579 c----------------------------------------------------------------------------
5580       subroutine etor_d(etors_d)
5581 C 6/23/01 Compute double torsional energy
5582       implicit real*8 (a-h,o-z)
5583       include 'DIMENSIONS'
5584       include 'COMMON.VAR'
5585       include 'COMMON.GEO'
5586       include 'COMMON.LOCAL'
5587       include 'COMMON.TORSION'
5588       include 'COMMON.INTERACT'
5589       include 'COMMON.DERIV'
5590       include 'COMMON.CHAIN'
5591       include 'COMMON.NAMES'
5592       include 'COMMON.IOUNITS'
5593       include 'COMMON.FFIELD'
5594       include 'COMMON.TORCNSTR'
5595       logical lprn
5596 C Set lprn=.true. for debugging
5597       lprn=.false.
5598 c     lprn=.true.
5599       etors_d=0.0D0
5600       do i=iphid_start,iphid_end
5601         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5602      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle
5603         itori=itortyp(itype(i-2))
5604         itori1=itortyp(itype(i-1))
5605         itori2=itortyp(itype(i))
5606         phii=phi(i)
5607         phii1=phi(i+1)
5608         gloci1=0.0D0
5609         gloci2=0.0D0
5610 C Regular cosine and sine terms
5611         do j=1,ntermd_1(itori,itori1,itori2)
5612           v1cij=v1c(1,j,itori,itori1,itori2)
5613           v1sij=v1s(1,j,itori,itori1,itori2)
5614           v2cij=v1c(2,j,itori,itori1,itori2)
5615           v2sij=v1s(2,j,itori,itori1,itori2)
5616           cosphi1=dcos(j*phii)
5617           sinphi1=dsin(j*phii)
5618           cosphi2=dcos(j*phii1)
5619           sinphi2=dsin(j*phii1)
5620           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5621      &     v2cij*cosphi2+v2sij*sinphi2
5622           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5623           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5624         enddo
5625         do k=2,ntermd_2(itori,itori1,itori2)
5626           do l=1,k-1
5627             v1cdij = v2c(k,l,itori,itori1,itori2)
5628             v2cdij = v2c(l,k,itori,itori1,itori2)
5629             v1sdij = v2s(k,l,itori,itori1,itori2)
5630             v2sdij = v2s(l,k,itori,itori1,itori2)
5631             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5632             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5633             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5634             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5635             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5636      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5637             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5638      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5639             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5640      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5641           enddo
5642         enddo
5643         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5644         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5645       enddo
5646       return
5647       end
5648 #endif
5649 c------------------------------------------------------------------------------
5650       subroutine eback_sc_corr(esccor)
5651 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5652 c        conformational states; temporarily implemented as differences
5653 c        between UNRES torsional potentials (dependent on three types of
5654 c        residues) and the torsional potentials dependent on all 20 types
5655 c        of residues computed from AM1  energy surfaces of terminally-blocked
5656 c        amino-acid residues.
5657       implicit real*8 (a-h,o-z)
5658       include 'DIMENSIONS'
5659       include 'COMMON.VAR'
5660       include 'COMMON.GEO'
5661       include 'COMMON.LOCAL'
5662       include 'COMMON.TORSION'
5663       include 'COMMON.SCCOR'
5664       include 'COMMON.INTERACT'
5665       include 'COMMON.DERIV'
5666       include 'COMMON.CHAIN'
5667       include 'COMMON.NAMES'
5668       include 'COMMON.IOUNITS'
5669       include 'COMMON.FFIELD'
5670       include 'COMMON.CONTROL'
5671       logical lprn
5672 C Set lprn=.true. for debugging
5673       lprn=.false.
5674 c      lprn=.true.
5675 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5676       esccor=0.0D0
5677       do i=iphi_start,iphi_end
5678         if (itype(i-2).eq.21 .or. itype(i-1).eq.21) cycle
5679         esccor_ii=0.0D0
5680         itori=itype(i-2)
5681         itori1=itype(i-1)
5682         phii=phi(i)
5683         gloci=0.0D0
5684         do j=1,nterm_sccor
5685           v1ij=v1sccor(j,itori,itori1)
5686           v2ij=v2sccor(j,itori,itori1)
5687           cosphi=dcos(j*phii)
5688           sinphi=dsin(j*phii)
5689           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5690           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5691         enddo
5692         if (lprn)
5693      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5694      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5695      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5696         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5697       enddo
5698       return
5699       end
5700 c----------------------------------------------------------------------------
5701       subroutine multibody(ecorr)
5702 C This subroutine calculates multi-body contributions to energy following
5703 C the idea of Skolnick et al. If side chains I and J make a contact and
5704 C at the same time side chains I+1 and J+1 make a contact, an extra
5705 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5706       implicit real*8 (a-h,o-z)
5707       include 'DIMENSIONS'
5708       include 'COMMON.IOUNITS'
5709       include 'COMMON.DERIV'
5710       include 'COMMON.INTERACT'
5711       include 'COMMON.CONTACTS'
5712       double precision gx(3),gx1(3)
5713       logical lprn
5714
5715 C Set lprn=.true. for debugging
5716       lprn=.false.
5717
5718       if (lprn) then
5719         write (iout,'(a)') 'Contact function values:'
5720         do i=nnt,nct-2
5721           write (iout,'(i2,20(1x,i2,f10.5))')
5722      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5723         enddo
5724       endif
5725       ecorr=0.0D0
5726       do i=nnt,nct
5727         do j=1,3
5728           gradcorr(j,i)=0.0D0
5729           gradxorr(j,i)=0.0D0
5730         enddo
5731       enddo
5732       do i=nnt,nct-2
5733
5734         DO ISHIFT = 3,4
5735
5736         i1=i+ishift
5737         num_conti=num_cont(i)
5738         num_conti1=num_cont(i1)
5739         do jj=1,num_conti
5740           j=jcont(jj,i)
5741           do kk=1,num_conti1
5742             j1=jcont(kk,i1)
5743             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5744 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5745 cd   &                   ' ishift=',ishift
5746 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5747 C The system gains extra energy.
5748               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5749             endif   ! j1==j+-ishift
5750           enddo     ! kk
5751         enddo       ! jj
5752
5753         ENDDO ! ISHIFT
5754
5755       enddo         ! i
5756       return
5757       end
5758 c------------------------------------------------------------------------------
5759       double precision function esccorr(i,j,k,l,jj,kk)
5760       implicit real*8 (a-h,o-z)
5761       include 'DIMENSIONS'
5762       include 'COMMON.IOUNITS'
5763       include 'COMMON.DERIV'
5764       include 'COMMON.INTERACT'
5765       include 'COMMON.CONTACTS'
5766       double precision gx(3),gx1(3)
5767       logical lprn
5768       lprn=.false.
5769       eij=facont(jj,i)
5770       ekl=facont(kk,k)
5771 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5772 C Calculate the multi-body contribution to energy.
5773 C Calculate multi-body contributions to the gradient.
5774 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5775 cd   & k,l,(gacont(m,kk,k),m=1,3)
5776       do m=1,3
5777         gx(m) =ekl*gacont(m,jj,i)
5778         gx1(m)=eij*gacont(m,kk,k)
5779         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5780         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5781         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5782         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5783       enddo
5784       do m=i,j-1
5785         do ll=1,3
5786           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5787         enddo
5788       enddo
5789       do m=k,l-1
5790         do ll=1,3
5791           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5792         enddo
5793       enddo
5794       esccorr=-eij*ekl
5795       return
5796       end
5797 c------------------------------------------------------------------------------
5798       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5799 C This subroutine calculates multi-body contributions to hydrogen-bonding
5800       implicit real*8 (a-h,o-z)
5801       include 'DIMENSIONS'
5802       include 'COMMON.IOUNITS'
5803 #ifdef MPI
5804       include "mpif.h"
5805       parameter (max_cont=maxconts)
5806       parameter (max_dim=26)
5807       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5808       double precision zapas(max_dim,maxconts,max_fg_procs),
5809      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5810       common /przechowalnia/ zapas
5811       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5812      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5813 #endif
5814       include 'COMMON.SETUP'
5815       include 'COMMON.FFIELD'
5816       include 'COMMON.DERIV'
5817       include 'COMMON.INTERACT'
5818       include 'COMMON.CONTACTS'
5819       include 'COMMON.CONTROL'
5820       include 'COMMON.LOCAL'
5821       double precision gx(3),gx1(3),time00
5822       logical lprn,ldone
5823
5824 C Set lprn=.true. for debugging
5825       lprn=.false.
5826 #ifdef MPI
5827       n_corr=0
5828       n_corr1=0
5829       if (nfgtasks.le.1) goto 30
5830       if (lprn) then
5831         write (iout,'(a)') 'Contact function values before RECEIVE:'
5832         do i=nnt,nct-2
5833           write (iout,'(2i3,50(1x,i2,f5.2))')
5834      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5835      &    j=1,num_cont_hb(i))
5836         enddo
5837       endif
5838       call flush(iout)
5839       do i=1,ntask_cont_from
5840         ncont_recv(i)=0
5841       enddo
5842       do i=1,ntask_cont_to
5843         ncont_sent(i)=0
5844       enddo
5845 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5846 c     & ntask_cont_to
5847 C Make the list of contacts to send to send to other procesors
5848 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5849 c      call flush(iout)
5850       do i=iturn3_start,iturn3_end
5851 c        write (iout,*) "make contact list turn3",i," num_cont",
5852 c     &    num_cont_hb(i)
5853         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5854       enddo
5855       do i=iturn4_start,iturn4_end
5856 c        write (iout,*) "make contact list turn4",i," num_cont",
5857 c     &   num_cont_hb(i)
5858         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5859       enddo
5860       do ii=1,nat_sent
5861         i=iat_sent(ii)
5862 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5863 c     &    num_cont_hb(i)
5864         do j=1,num_cont_hb(i)
5865         do k=1,4
5866           jjc=jcont_hb(j,i)
5867           iproc=iint_sent_local(k,jjc,ii)
5868 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5869           if (iproc.gt.0) then
5870             ncont_sent(iproc)=ncont_sent(iproc)+1
5871             nn=ncont_sent(iproc)
5872             zapas(1,nn,iproc)=i
5873             zapas(2,nn,iproc)=jjc
5874             zapas(3,nn,iproc)=facont_hb(j,i)
5875             zapas(4,nn,iproc)=ees0p(j,i)
5876             zapas(5,nn,iproc)=ees0m(j,i)
5877             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5878             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5879             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5880             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5881             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5882             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5883             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5884             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5885             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5886             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5887             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5888             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5889             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5890             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5891             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5892             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5893             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5894             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5895             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5896             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5897             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5898           endif
5899         enddo
5900         enddo
5901       enddo
5902       if (lprn) then
5903       write (iout,*)
5904      &  "Numbers of contacts to be sent to other processors",
5905      &  (ncont_sent(i),i=1,ntask_cont_to)
5906       write (iout,*) "Contacts sent"
5907       do ii=1,ntask_cont_to
5908         nn=ncont_sent(ii)
5909         iproc=itask_cont_to(ii)
5910         write (iout,*) nn," contacts to processor",iproc,
5911      &   " of CONT_TO_COMM group"
5912         do i=1,nn
5913           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5914         enddo
5915       enddo
5916       call flush(iout)
5917       endif
5918       CorrelType=477
5919       CorrelID=fg_rank+1
5920       CorrelType1=478
5921       CorrelID1=nfgtasks+fg_rank+1
5922       ireq=0
5923 C Receive the numbers of needed contacts from other processors
5924       do ii=1,ntask_cont_from
5925         iproc=itask_cont_from(ii)
5926         ireq=ireq+1
5927         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
5928      &    FG_COMM,req(ireq),IERR)
5929       enddo
5930 c      write (iout,*) "IRECV ended"
5931 c      call flush(iout)
5932 C Send the number of contacts needed by other processors
5933       do ii=1,ntask_cont_to
5934         iproc=itask_cont_to(ii)
5935         ireq=ireq+1
5936         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
5937      &    FG_COMM,req(ireq),IERR)
5938       enddo
5939 c      write (iout,*) "ISEND ended"
5940 c      write (iout,*) "number of requests (nn)",ireq
5941       call flush(iout)
5942       if (ireq.gt.0)
5943      &  call MPI_Waitall(ireq,req,status_array,ierr)
5944 c      write (iout,*)
5945 c     &  "Numbers of contacts to be received from other processors",
5946 c     &  (ncont_recv(i),i=1,ntask_cont_from)
5947 c      call flush(iout)
5948 C Receive contacts
5949       ireq=0
5950       do ii=1,ntask_cont_from
5951         iproc=itask_cont_from(ii)
5952         nn=ncont_recv(ii)
5953 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
5954 c     &   " of CONT_TO_COMM group"
5955         call flush(iout)
5956         if (nn.gt.0) then
5957           ireq=ireq+1
5958           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
5959      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
5960 c          write (iout,*) "ireq,req",ireq,req(ireq)
5961         endif
5962       enddo
5963 C Send the contacts to processors that need them
5964       do ii=1,ntask_cont_to
5965         iproc=itask_cont_to(ii)
5966         nn=ncont_sent(ii)
5967 c        write (iout,*) nn," contacts to processor",iproc,
5968 c     &   " of CONT_TO_COMM group"
5969         if (nn.gt.0) then
5970           ireq=ireq+1
5971           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
5972      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
5973 c          write (iout,*) "ireq,req",ireq,req(ireq)
5974 c          do i=1,nn
5975 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5976 c          enddo
5977         endif
5978       enddo
5979 c      write (iout,*) "number of requests (contacts)",ireq
5980 c      write (iout,*) "req",(req(i),i=1,4)
5981 c      call flush(iout)
5982       if (ireq.gt.0)
5983      & call MPI_Waitall(ireq,req,status_array,ierr)
5984       do iii=1,ntask_cont_from
5985         iproc=itask_cont_from(iii)
5986         nn=ncont_recv(iii)
5987         if (lprn) then
5988         write (iout,*) "Received",nn," contacts from processor",iproc,
5989      &   " of CONT_FROM_COMM group"
5990         call flush(iout)
5991         do i=1,nn
5992           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
5993         enddo
5994         call flush(iout)
5995         endif
5996         do i=1,nn
5997           ii=zapas_recv(1,i,iii)
5998 c Flag the received contacts to prevent double-counting
5999           jj=-zapas_recv(2,i,iii)
6000 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6001 c          call flush(iout)
6002           nnn=num_cont_hb(ii)+1
6003           num_cont_hb(ii)=nnn
6004           jcont_hb(nnn,ii)=jj
6005           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6006           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6007           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6008           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6009           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6010           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6011           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6012           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6013           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6014           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6015           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6016           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6017           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6018           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6019           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6020           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6021           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6022           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6023           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6024           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6025           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6026           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6027           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6028           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6029         enddo
6030       enddo
6031       call flush(iout)
6032       if (lprn) then
6033         write (iout,'(a)') 'Contact function values after receive:'
6034         do i=nnt,nct-2
6035           write (iout,'(2i3,50(1x,i3,f5.2))')
6036      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6037      &    j=1,num_cont_hb(i))
6038         enddo
6039         call flush(iout)
6040       endif
6041    30 continue
6042 #endif
6043       if (lprn) then
6044         write (iout,'(a)') 'Contact function values:'
6045         do i=nnt,nct-2
6046           write (iout,'(2i3,50(1x,i3,f5.2))')
6047      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6048      &    j=1,num_cont_hb(i))
6049         enddo
6050       endif
6051       ecorr=0.0D0
6052 C Remove the loop below after debugging !!!
6053       do i=nnt,nct
6054         do j=1,3
6055           gradcorr(j,i)=0.0D0
6056           gradxorr(j,i)=0.0D0
6057         enddo
6058       enddo
6059 C Calculate the local-electrostatic correlation terms
6060       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6061         i1=i+1
6062         num_conti=num_cont_hb(i)
6063         num_conti1=num_cont_hb(i+1)
6064         do jj=1,num_conti
6065           j=jcont_hb(jj,i)
6066           jp=iabs(j)
6067           do kk=1,num_conti1
6068             j1=jcont_hb(kk,i1)
6069             jp1=iabs(j1)
6070 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6071 c     &         ' jj=',jj,' kk=',kk
6072             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6073      &          .or. j.lt.0 .and. j1.gt.0) .and.
6074      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6075 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6076 C The system gains extra energy.
6077               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6078               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6079      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6080               n_corr=n_corr+1
6081             else if (j1.eq.j) then
6082 C Contacts I-J and I-(J+1) occur simultaneously.
6083 C The system loses extra energy.
6084 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6085             endif
6086           enddo ! kk
6087           do kk=1,num_conti
6088             j1=jcont_hb(kk,i)
6089 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6090 c    &         ' jj=',jj,' kk=',kk
6091             if (j1.eq.j+1) then
6092 C Contacts I-J and (I+1)-J occur simultaneously.
6093 C The system loses extra energy.
6094 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6095             endif ! j1==j+1
6096           enddo ! kk
6097         enddo ! jj
6098       enddo ! i
6099       return
6100       end
6101 c------------------------------------------------------------------------------
6102       subroutine add_hb_contact(ii,jj,itask)
6103       implicit real*8 (a-h,o-z)
6104       include "DIMENSIONS"
6105       include "COMMON.IOUNITS"
6106       integer max_cont
6107       integer max_dim
6108       parameter (max_cont=maxconts)
6109       parameter (max_dim=26)
6110       include "COMMON.CONTACTS"
6111       double precision zapas(max_dim,maxconts,max_fg_procs),
6112      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6113       common /przechowalnia/ zapas
6114       integer i,j,ii,jj,iproc,itask(4),nn
6115 c      write (iout,*) "itask",itask
6116       do i=1,2
6117         iproc=itask(i)
6118         if (iproc.gt.0) then
6119           do j=1,num_cont_hb(ii)
6120             jjc=jcont_hb(j,ii)
6121 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6122             if (jjc.eq.jj) then
6123               ncont_sent(iproc)=ncont_sent(iproc)+1
6124               nn=ncont_sent(iproc)
6125               zapas(1,nn,iproc)=ii
6126               zapas(2,nn,iproc)=jjc
6127               zapas(3,nn,iproc)=facont_hb(j,ii)
6128               zapas(4,nn,iproc)=ees0p(j,ii)
6129               zapas(5,nn,iproc)=ees0m(j,ii)
6130               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6131               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6132               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6133               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6134               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6135               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6136               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6137               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6138               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6139               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6140               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6141               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6142               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6143               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6144               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6145               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6146               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6147               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6148               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6149               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6150               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6151               exit
6152             endif
6153           enddo
6154         endif
6155       enddo
6156       return
6157       end
6158 c------------------------------------------------------------------------------
6159       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6160      &  n_corr1)
6161 C This subroutine calculates multi-body contributions to hydrogen-bonding
6162       implicit real*8 (a-h,o-z)
6163       include 'DIMENSIONS'
6164       include 'COMMON.IOUNITS'
6165 #ifdef MPI
6166       include "mpif.h"
6167       parameter (max_cont=maxconts)
6168       parameter (max_dim=70)
6169       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6170       double precision zapas(max_dim,maxconts,max_fg_procs),
6171      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6172       common /przechowalnia/ zapas
6173       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6174      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6175 #endif
6176       include 'COMMON.SETUP'
6177       include 'COMMON.FFIELD'
6178       include 'COMMON.DERIV'
6179       include 'COMMON.LOCAL'
6180       include 'COMMON.INTERACT'
6181       include 'COMMON.CONTACTS'
6182       include 'COMMON.CHAIN'
6183       include 'COMMON.CONTROL'
6184       double precision gx(3),gx1(3)
6185       integer num_cont_hb_old(maxres)
6186       logical lprn,ldone
6187       double precision eello4,eello5,eelo6,eello_turn6
6188       external eello4,eello5,eello6,eello_turn6
6189 C Set lprn=.true. for debugging
6190       lprn=.false.
6191       eturn6=0.0d0
6192 #ifdef MPI
6193       do i=1,nres
6194         num_cont_hb_old(i)=num_cont_hb(i)
6195       enddo
6196       n_corr=0
6197       n_corr1=0
6198       if (nfgtasks.le.1) goto 30
6199       if (lprn) then
6200         write (iout,'(a)') 'Contact function values before RECEIVE:'
6201         do i=nnt,nct-2
6202           write (iout,'(2i3,50(1x,i2,f5.2))')
6203      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6204      &    j=1,num_cont_hb(i))
6205         enddo
6206       endif
6207       call flush(iout)
6208       do i=1,ntask_cont_from
6209         ncont_recv(i)=0
6210       enddo
6211       do i=1,ntask_cont_to
6212         ncont_sent(i)=0
6213       enddo
6214 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6215 c     & ntask_cont_to
6216 C Make the list of contacts to send to send to other procesors
6217       do i=iturn3_start,iturn3_end
6218 c        write (iout,*) "make contact list turn3",i," num_cont",
6219 c     &    num_cont_hb(i)
6220         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6221       enddo
6222       do i=iturn4_start,iturn4_end
6223 c        write (iout,*) "make contact list turn4",i," num_cont",
6224 c     &   num_cont_hb(i)
6225         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6226       enddo
6227       do ii=1,nat_sent
6228         i=iat_sent(ii)
6229 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6230 c     &    num_cont_hb(i)
6231         do j=1,num_cont_hb(i)
6232         do k=1,4
6233           jjc=jcont_hb(j,i)
6234           iproc=iint_sent_local(k,jjc,ii)
6235 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6236           if (iproc.ne.0) then
6237             ncont_sent(iproc)=ncont_sent(iproc)+1
6238             nn=ncont_sent(iproc)
6239             zapas(1,nn,iproc)=i
6240             zapas(2,nn,iproc)=jjc
6241             zapas(3,nn,iproc)=d_cont(j,i)
6242             ind=3
6243             do kk=1,3
6244               ind=ind+1
6245               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6246             enddo
6247             do kk=1,2
6248               do ll=1,2
6249                 ind=ind+1
6250                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6251               enddo
6252             enddo
6253             do jj=1,5
6254               do kk=1,3
6255                 do ll=1,2
6256                   do mm=1,2
6257                     ind=ind+1
6258                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6259                   enddo
6260                 enddo
6261               enddo
6262             enddo
6263           endif
6264         enddo
6265         enddo
6266       enddo
6267       if (lprn) then
6268       write (iout,*)
6269      &  "Numbers of contacts to be sent to other processors",
6270      &  (ncont_sent(i),i=1,ntask_cont_to)
6271       write (iout,*) "Contacts sent"
6272       do ii=1,ntask_cont_to
6273         nn=ncont_sent(ii)
6274         iproc=itask_cont_to(ii)
6275         write (iout,*) nn," contacts to processor",iproc,
6276      &   " of CONT_TO_COMM group"
6277         do i=1,nn
6278           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6279         enddo
6280       enddo
6281       call flush(iout)
6282       endif
6283       CorrelType=477
6284       CorrelID=fg_rank+1
6285       CorrelType1=478
6286       CorrelID1=nfgtasks+fg_rank+1
6287       ireq=0
6288 C Receive the numbers of needed contacts from other processors
6289       do ii=1,ntask_cont_from
6290         iproc=itask_cont_from(ii)
6291         ireq=ireq+1
6292         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6293      &    FG_COMM,req(ireq),IERR)
6294       enddo
6295 c      write (iout,*) "IRECV ended"
6296 c      call flush(iout)
6297 C Send the number of contacts needed by other processors
6298       do ii=1,ntask_cont_to
6299         iproc=itask_cont_to(ii)
6300         ireq=ireq+1
6301         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6302      &    FG_COMM,req(ireq),IERR)
6303       enddo
6304 c      write (iout,*) "ISEND ended"
6305 c      write (iout,*) "number of requests (nn)",ireq
6306       call flush(iout)
6307       if (ireq.gt.0)
6308      &  call MPI_Waitall(ireq,req,status_array,ierr)
6309 c      write (iout,*)
6310 c     &  "Numbers of contacts to be received from other processors",
6311 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6312 c      call flush(iout)
6313 C Receive contacts
6314       ireq=0
6315       do ii=1,ntask_cont_from
6316         iproc=itask_cont_from(ii)
6317         nn=ncont_recv(ii)
6318 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6319 c     &   " of CONT_TO_COMM group"
6320         call flush(iout)
6321         if (nn.gt.0) then
6322           ireq=ireq+1
6323           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6324      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6325 c          write (iout,*) "ireq,req",ireq,req(ireq)
6326         endif
6327       enddo
6328 C Send the contacts to processors that need them
6329       do ii=1,ntask_cont_to
6330         iproc=itask_cont_to(ii)
6331         nn=ncont_sent(ii)
6332 c        write (iout,*) nn," contacts to processor",iproc,
6333 c     &   " of CONT_TO_COMM group"
6334         if (nn.gt.0) then
6335           ireq=ireq+1
6336           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6337      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6338 c          write (iout,*) "ireq,req",ireq,req(ireq)
6339 c          do i=1,nn
6340 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6341 c          enddo
6342         endif
6343       enddo
6344 c      write (iout,*) "number of requests (contacts)",ireq
6345 c      write (iout,*) "req",(req(i),i=1,4)
6346 c      call flush(iout)
6347       if (ireq.gt.0)
6348      & call MPI_Waitall(ireq,req,status_array,ierr)
6349       do iii=1,ntask_cont_from
6350         iproc=itask_cont_from(iii)
6351         nn=ncont_recv(iii)
6352         if (lprn) then
6353         write (iout,*) "Received",nn," contacts from processor",iproc,
6354      &   " of CONT_FROM_COMM group"
6355         call flush(iout)
6356         do i=1,nn
6357           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6358         enddo
6359         call flush(iout)
6360         endif
6361         do i=1,nn
6362           ii=zapas_recv(1,i,iii)
6363 c Flag the received contacts to prevent double-counting
6364           jj=-zapas_recv(2,i,iii)
6365 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6366 c          call flush(iout)
6367           nnn=num_cont_hb(ii)+1
6368           num_cont_hb(ii)=nnn
6369           jcont_hb(nnn,ii)=jj
6370           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6371           ind=3
6372           do kk=1,3
6373             ind=ind+1
6374             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6375           enddo
6376           do kk=1,2
6377             do ll=1,2
6378               ind=ind+1
6379               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6380             enddo
6381           enddo
6382           do jj=1,5
6383             do kk=1,3
6384               do ll=1,2
6385                 do mm=1,2
6386                   ind=ind+1
6387                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6388                 enddo
6389               enddo
6390             enddo
6391           enddo
6392         enddo
6393       enddo
6394       call flush(iout)
6395       if (lprn) then
6396         write (iout,'(a)') 'Contact function values after receive:'
6397         do i=nnt,nct-2
6398           write (iout,'(2i3,50(1x,i3,5f6.3))')
6399      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6400      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6401         enddo
6402         call flush(iout)
6403       endif
6404    30 continue
6405 #endif
6406       if (lprn) then
6407         write (iout,'(a)') 'Contact function values:'
6408         do i=nnt,nct-2
6409           write (iout,'(2i3,50(1x,i2,5f6.3))')
6410      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6411      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6412         enddo
6413       endif
6414       ecorr=0.0D0
6415       ecorr5=0.0d0
6416       ecorr6=0.0d0
6417 C Remove the loop below after debugging !!!
6418       do i=nnt,nct
6419         do j=1,3
6420           gradcorr(j,i)=0.0D0
6421           gradxorr(j,i)=0.0D0
6422         enddo
6423       enddo
6424 C Calculate the dipole-dipole interaction energies
6425       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6426       do i=iatel_s,iatel_e+1
6427         num_conti=num_cont_hb(i)
6428         do jj=1,num_conti
6429           j=jcont_hb(jj,i)
6430 #ifdef MOMENT
6431           call dipole(i,j,jj)
6432 #endif
6433         enddo
6434       enddo
6435       endif
6436 C Calculate the local-electrostatic correlation terms
6437 c                write (iout,*) "gradcorr5 in eello5 before loop"
6438 c                do iii=1,nres
6439 c                  write (iout,'(i5,3f10.5)')
6440 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6441 c                enddo
6442       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6443 c        write (iout,*) "corr loop i",i
6444         i1=i+1
6445         num_conti=num_cont_hb(i)
6446         num_conti1=num_cont_hb(i+1)
6447         do jj=1,num_conti
6448           j=jcont_hb(jj,i)
6449           jp=iabs(j)
6450           do kk=1,num_conti1
6451             j1=jcont_hb(kk,i1)
6452             jp1=iabs(j1)
6453 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6454 c     &         ' jj=',jj,' kk=',kk
6455 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6456             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6457      &          .or. j.lt.0 .and. j1.gt.0) .and.
6458      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6459 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6460 C The system gains extra energy.
6461               n_corr=n_corr+1
6462               sqd1=dsqrt(d_cont(jj,i))
6463               sqd2=dsqrt(d_cont(kk,i1))
6464               sred_geom = sqd1*sqd2
6465               IF (sred_geom.lt.cutoff_corr) THEN
6466                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6467      &            ekont,fprimcont)
6468 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6469 cd     &         ' jj=',jj,' kk=',kk
6470                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6471                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6472                 do l=1,3
6473                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6474                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6475                 enddo
6476                 n_corr1=n_corr1+1
6477 cd               write (iout,*) 'sred_geom=',sred_geom,
6478 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6479 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6480 cd               write (iout,*) "g_contij",g_contij
6481 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6482 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6483                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6484                 if (wcorr4.gt.0.0d0)
6485      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6486                   if (energy_dec.and.wcorr4.gt.0.0d0)
6487      1                 write (iout,'(a6,4i5,0pf7.3)')
6488      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6489 c                write (iout,*) "gradcorr5 before eello5"
6490 c                do iii=1,nres
6491 c                  write (iout,'(i5,3f10.5)')
6492 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6493 c                enddo
6494                 if (wcorr5.gt.0.0d0)
6495      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6496 c                write (iout,*) "gradcorr5 after eello5"
6497 c                do iii=1,nres
6498 c                  write (iout,'(i5,3f10.5)')
6499 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6500 c                enddo
6501                   if (energy_dec.and.wcorr5.gt.0.0d0)
6502      1                 write (iout,'(a6,4i5,0pf7.3)')
6503      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6504 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6505 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6506                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6507      &               .or. wturn6.eq.0.0d0))then
6508 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6509                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6510                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6511      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6512 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6513 cd     &            'ecorr6=',ecorr6
6514 cd                write (iout,'(4e15.5)') sred_geom,
6515 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6516 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6517 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6518                 else if (wturn6.gt.0.0d0
6519      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6520 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6521                   eturn6=eturn6+eello_turn6(i,jj,kk)
6522                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6523      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6524 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6525                 endif
6526               ENDIF
6527 1111          continue
6528             endif
6529           enddo ! kk
6530         enddo ! jj
6531       enddo ! i
6532       do i=1,nres
6533         num_cont_hb(i)=num_cont_hb_old(i)
6534       enddo
6535 c                write (iout,*) "gradcorr5 in eello5"
6536 c                do iii=1,nres
6537 c                  write (iout,'(i5,3f10.5)')
6538 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6539 c                enddo
6540       return
6541       end
6542 c------------------------------------------------------------------------------
6543       subroutine add_hb_contact_eello(ii,jj,itask)
6544       implicit real*8 (a-h,o-z)
6545       include "DIMENSIONS"
6546       include "COMMON.IOUNITS"
6547       integer max_cont
6548       integer max_dim
6549       parameter (max_cont=maxconts)
6550       parameter (max_dim=70)
6551       include "COMMON.CONTACTS"
6552       double precision zapas(max_dim,maxconts,max_fg_procs),
6553      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6554       common /przechowalnia/ zapas
6555       integer i,j,ii,jj,iproc,itask(4),nn
6556 c      write (iout,*) "itask",itask
6557       do i=1,2
6558         iproc=itask(i)
6559         if (iproc.gt.0) then
6560           do j=1,num_cont_hb(ii)
6561             jjc=jcont_hb(j,ii)
6562 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6563             if (jjc.eq.jj) then
6564               ncont_sent(iproc)=ncont_sent(iproc)+1
6565               nn=ncont_sent(iproc)
6566               zapas(1,nn,iproc)=ii
6567               zapas(2,nn,iproc)=jjc
6568               zapas(3,nn,iproc)=d_cont(j,ii)
6569               ind=3
6570               do kk=1,3
6571                 ind=ind+1
6572                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6573               enddo
6574               do kk=1,2
6575                 do ll=1,2
6576                   ind=ind+1
6577                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6578                 enddo
6579               enddo
6580               do jj=1,5
6581                 do kk=1,3
6582                   do ll=1,2
6583                     do mm=1,2
6584                       ind=ind+1
6585                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6586                     enddo
6587                   enddo
6588                 enddo
6589               enddo
6590               exit
6591             endif
6592           enddo
6593         endif
6594       enddo
6595       return
6596       end
6597 c------------------------------------------------------------------------------
6598       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6599       implicit real*8 (a-h,o-z)
6600       include 'DIMENSIONS'
6601       include 'COMMON.IOUNITS'
6602       include 'COMMON.DERIV'
6603       include 'COMMON.INTERACT'
6604       include 'COMMON.CONTACTS'
6605       double precision gx(3),gx1(3)
6606       logical lprn
6607       lprn=.false.
6608       eij=facont_hb(jj,i)
6609       ekl=facont_hb(kk,k)
6610       ees0pij=ees0p(jj,i)
6611       ees0pkl=ees0p(kk,k)
6612       ees0mij=ees0m(jj,i)
6613       ees0mkl=ees0m(kk,k)
6614       ekont=eij*ekl
6615       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6616 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6617 C Following 4 lines for diagnostics.
6618 cd    ees0pkl=0.0D0
6619 cd    ees0pij=1.0D0
6620 cd    ees0mkl=0.0D0
6621 cd    ees0mij=1.0D0
6622 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6623 c     & 'Contacts ',i,j,
6624 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6625 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6626 c     & 'gradcorr_long'
6627 C Calculate the multi-body contribution to energy.
6628 c      ecorr=ecorr+ekont*ees
6629 C Calculate multi-body contributions to the gradient.
6630       coeffpees0pij=coeffp*ees0pij
6631       coeffmees0mij=coeffm*ees0mij
6632       coeffpees0pkl=coeffp*ees0pkl
6633       coeffmees0mkl=coeffm*ees0mkl
6634       do ll=1,3
6635 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6636         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6637      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6638      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6639         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6640      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6641      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6642 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6643         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6644      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6645      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6646         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6647      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6648      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6649         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6650      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6651      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6652         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6653         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6654         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6655      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6656      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6657         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6658         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6659 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6660       enddo
6661 c      write (iout,*)
6662 cgrad      do m=i+1,j-1
6663 cgrad        do ll=1,3
6664 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6665 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6666 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6667 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6668 cgrad        enddo
6669 cgrad      enddo
6670 cgrad      do m=k+1,l-1
6671 cgrad        do ll=1,3
6672 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6673 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6674 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6675 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6676 cgrad        enddo
6677 cgrad      enddo
6678 c      write (iout,*) "ehbcorr",ekont*ees
6679       ehbcorr=ekont*ees
6680       return
6681       end
6682 #ifdef MOMENT
6683 C---------------------------------------------------------------------------
6684       subroutine dipole(i,j,jj)
6685       implicit real*8 (a-h,o-z)
6686       include 'DIMENSIONS'
6687       include 'COMMON.IOUNITS'
6688       include 'COMMON.CHAIN'
6689       include 'COMMON.FFIELD'
6690       include 'COMMON.DERIV'
6691       include 'COMMON.INTERACT'
6692       include 'COMMON.CONTACTS'
6693       include 'COMMON.TORSION'
6694       include 'COMMON.VAR'
6695       include 'COMMON.GEO'
6696       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6697      &  auxmat(2,2)
6698       iti1 = itortyp(itype(i+1))
6699       if (j.lt.nres-1) then
6700         itj1 = itortyp(itype(j+1))
6701       else
6702         itj1=ntortyp+1
6703       endif
6704       do iii=1,2
6705         dipi(iii,1)=Ub2(iii,i)
6706         dipderi(iii)=Ub2der(iii,i)
6707         dipi(iii,2)=b1(iii,iti1)
6708         dipj(iii,1)=Ub2(iii,j)
6709         dipderj(iii)=Ub2der(iii,j)
6710         dipj(iii,2)=b1(iii,itj1)
6711       enddo
6712       kkk=0
6713       do iii=1,2
6714         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6715         do jjj=1,2
6716           kkk=kkk+1
6717           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6718         enddo
6719       enddo
6720       do kkk=1,5
6721         do lll=1,3
6722           mmm=0
6723           do iii=1,2
6724             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6725      &        auxvec(1))
6726             do jjj=1,2
6727               mmm=mmm+1
6728               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6729             enddo
6730           enddo
6731         enddo
6732       enddo
6733       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6734       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6735       do iii=1,2
6736         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6737       enddo
6738       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6739       do iii=1,2
6740         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6741       enddo
6742       return
6743       end
6744 #endif
6745 C---------------------------------------------------------------------------
6746       subroutine calc_eello(i,j,k,l,jj,kk)
6747 C
6748 C This subroutine computes matrices and vectors needed to calculate
6749 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6750 C
6751       implicit real*8 (a-h,o-z)
6752       include 'DIMENSIONS'
6753       include 'COMMON.IOUNITS'
6754       include 'COMMON.CHAIN'
6755       include 'COMMON.DERIV'
6756       include 'COMMON.INTERACT'
6757       include 'COMMON.CONTACTS'
6758       include 'COMMON.TORSION'
6759       include 'COMMON.VAR'
6760       include 'COMMON.GEO'
6761       include 'COMMON.FFIELD'
6762       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6763      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6764       logical lprn
6765       common /kutas/ lprn
6766 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6767 cd     & ' jj=',jj,' kk=',kk
6768 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6769 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6770 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6771       do iii=1,2
6772         do jjj=1,2
6773           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6774           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6775         enddo
6776       enddo
6777       call transpose2(aa1(1,1),aa1t(1,1))
6778       call transpose2(aa2(1,1),aa2t(1,1))
6779       do kkk=1,5
6780         do lll=1,3
6781           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6782      &      aa1tder(1,1,lll,kkk))
6783           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6784      &      aa2tder(1,1,lll,kkk))
6785         enddo
6786       enddo
6787       if (l.eq.j+1) then
6788 C parallel orientation of the two CA-CA-CA frames.
6789         if (i.gt.1) then
6790           iti=itortyp(itype(i))
6791         else
6792           iti=ntortyp+1
6793         endif
6794         itk1=itortyp(itype(k+1))
6795         itj=itortyp(itype(j))
6796         if (l.lt.nres-1) then
6797           itl1=itortyp(itype(l+1))
6798         else
6799           itl1=ntortyp+1
6800         endif
6801 C A1 kernel(j+1) A2T
6802 cd        do iii=1,2
6803 cd          write (iout,'(3f10.5,5x,3f10.5)')
6804 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6805 cd        enddo
6806         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6807      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6808      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6809 C Following matrices are needed only for 6-th order cumulants
6810         IF (wcorr6.gt.0.0d0) THEN
6811         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6812      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6813      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6814         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6815      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6816      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6817      &   ADtEAderx(1,1,1,1,1,1))
6818         lprn=.false.
6819         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6820      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6821      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6822      &   ADtEA1derx(1,1,1,1,1,1))
6823         ENDIF
6824 C End 6-th order cumulants
6825 cd        lprn=.false.
6826 cd        if (lprn) then
6827 cd        write (2,*) 'In calc_eello6'
6828 cd        do iii=1,2
6829 cd          write (2,*) 'iii=',iii
6830 cd          do kkk=1,5
6831 cd            write (2,*) 'kkk=',kkk
6832 cd            do jjj=1,2
6833 cd              write (2,'(3(2f10.5),5x)')
6834 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6835 cd            enddo
6836 cd          enddo
6837 cd        enddo
6838 cd        endif
6839         call transpose2(EUgder(1,1,k),auxmat(1,1))
6840         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6841         call transpose2(EUg(1,1,k),auxmat(1,1))
6842         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6843         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6844         do iii=1,2
6845           do kkk=1,5
6846             do lll=1,3
6847               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6848      &          EAEAderx(1,1,lll,kkk,iii,1))
6849             enddo
6850           enddo
6851         enddo
6852 C A1T kernel(i+1) A2
6853         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6854      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6855      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6856 C Following matrices are needed only for 6-th order cumulants
6857         IF (wcorr6.gt.0.0d0) THEN
6858         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6859      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6860      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6861         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6862      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6863      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6864      &   ADtEAderx(1,1,1,1,1,2))
6865         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6866      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6867      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6868      &   ADtEA1derx(1,1,1,1,1,2))
6869         ENDIF
6870 C End 6-th order cumulants
6871         call transpose2(EUgder(1,1,l),auxmat(1,1))
6872         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6873         call transpose2(EUg(1,1,l),auxmat(1,1))
6874         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6875         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6876         do iii=1,2
6877           do kkk=1,5
6878             do lll=1,3
6879               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6880      &          EAEAderx(1,1,lll,kkk,iii,2))
6881             enddo
6882           enddo
6883         enddo
6884 C AEAb1 and AEAb2
6885 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6886 C They are needed only when the fifth- or the sixth-order cumulants are
6887 C indluded.
6888         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6889         call transpose2(AEA(1,1,1),auxmat(1,1))
6890         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6891         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6892         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6893         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6894         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6895         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6896         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6897         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6898         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6899         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6900         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6901         call transpose2(AEA(1,1,2),auxmat(1,1))
6902         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6903         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6904         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6905         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6906         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6907         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6908         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6909         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6910         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6911         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6912         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6913 C Calculate the Cartesian derivatives of the vectors.
6914         do iii=1,2
6915           do kkk=1,5
6916             do lll=1,3
6917               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6918               call matvec2(auxmat(1,1),b1(1,iti),
6919      &          AEAb1derx(1,lll,kkk,iii,1,1))
6920               call matvec2(auxmat(1,1),Ub2(1,i),
6921      &          AEAb2derx(1,lll,kkk,iii,1,1))
6922               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6923      &          AEAb1derx(1,lll,kkk,iii,2,1))
6924               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6925      &          AEAb2derx(1,lll,kkk,iii,2,1))
6926               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6927               call matvec2(auxmat(1,1),b1(1,itj),
6928      &          AEAb1derx(1,lll,kkk,iii,1,2))
6929               call matvec2(auxmat(1,1),Ub2(1,j),
6930      &          AEAb2derx(1,lll,kkk,iii,1,2))
6931               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6932      &          AEAb1derx(1,lll,kkk,iii,2,2))
6933               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6934      &          AEAb2derx(1,lll,kkk,iii,2,2))
6935             enddo
6936           enddo
6937         enddo
6938         ENDIF
6939 C End vectors
6940       else
6941 C Antiparallel orientation of the two CA-CA-CA frames.
6942         if (i.gt.1) then
6943           iti=itortyp(itype(i))
6944         else
6945           iti=ntortyp+1
6946         endif
6947         itk1=itortyp(itype(k+1))
6948         itl=itortyp(itype(l))
6949         itj=itortyp(itype(j))
6950         if (j.lt.nres-1) then
6951           itj1=itortyp(itype(j+1))
6952         else
6953           itj1=ntortyp+1
6954         endif
6955 C A2 kernel(j-1)T A1T
6956         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6957      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6958      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6959 C Following matrices are needed only for 6-th order cumulants
6960         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6961      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6962         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6963      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6964      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6965         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6966      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6967      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6968      &   ADtEAderx(1,1,1,1,1,1))
6969         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6970      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6971      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6972      &   ADtEA1derx(1,1,1,1,1,1))
6973         ENDIF
6974 C End 6-th order cumulants
6975         call transpose2(EUgder(1,1,k),auxmat(1,1))
6976         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6977         call transpose2(EUg(1,1,k),auxmat(1,1))
6978         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6979         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6980         do iii=1,2
6981           do kkk=1,5
6982             do lll=1,3
6983               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6984      &          EAEAderx(1,1,lll,kkk,iii,1))
6985             enddo
6986           enddo
6987         enddo
6988 C A2T kernel(i+1)T A1
6989         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6990      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6991      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6992 C Following matrices are needed only for 6-th order cumulants
6993         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6994      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6995         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6996      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6997      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6998         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6999      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7000      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7001      &   ADtEAderx(1,1,1,1,1,2))
7002         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7003      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7004      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7005      &   ADtEA1derx(1,1,1,1,1,2))
7006         ENDIF
7007 C End 6-th order cumulants
7008         call transpose2(EUgder(1,1,j),auxmat(1,1))
7009         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7010         call transpose2(EUg(1,1,j),auxmat(1,1))
7011         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7012         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7013         do iii=1,2
7014           do kkk=1,5
7015             do lll=1,3
7016               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7017      &          EAEAderx(1,1,lll,kkk,iii,2))
7018             enddo
7019           enddo
7020         enddo
7021 C AEAb1 and AEAb2
7022 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7023 C They are needed only when the fifth- or the sixth-order cumulants are
7024 C indluded.
7025         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7026      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7027         call transpose2(AEA(1,1,1),auxmat(1,1))
7028         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7029         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7030         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7031         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7032         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7033         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7034         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7035         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7036         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7037         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7038         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7039         call transpose2(AEA(1,1,2),auxmat(1,1))
7040         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7041         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7042         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7043         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7044         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7045         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7046         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7047         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7048         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7049         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7050         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7051 C Calculate the Cartesian derivatives of the vectors.
7052         do iii=1,2
7053           do kkk=1,5
7054             do lll=1,3
7055               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7056               call matvec2(auxmat(1,1),b1(1,iti),
7057      &          AEAb1derx(1,lll,kkk,iii,1,1))
7058               call matvec2(auxmat(1,1),Ub2(1,i),
7059      &          AEAb2derx(1,lll,kkk,iii,1,1))
7060               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7061      &          AEAb1derx(1,lll,kkk,iii,2,1))
7062               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7063      &          AEAb2derx(1,lll,kkk,iii,2,1))
7064               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7065               call matvec2(auxmat(1,1),b1(1,itl),
7066      &          AEAb1derx(1,lll,kkk,iii,1,2))
7067               call matvec2(auxmat(1,1),Ub2(1,l),
7068      &          AEAb2derx(1,lll,kkk,iii,1,2))
7069               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7070      &          AEAb1derx(1,lll,kkk,iii,2,2))
7071               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7072      &          AEAb2derx(1,lll,kkk,iii,2,2))
7073             enddo
7074           enddo
7075         enddo
7076         ENDIF
7077 C End vectors
7078       endif
7079       return
7080       end
7081 C---------------------------------------------------------------------------
7082       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7083      &  KK,KKderg,AKA,AKAderg,AKAderx)
7084       implicit none
7085       integer nderg
7086       logical transp
7087       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7088      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7089      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7090       integer iii,kkk,lll
7091       integer jjj,mmm
7092       logical lprn
7093       common /kutas/ lprn
7094       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7095       do iii=1,nderg
7096         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7097      &    AKAderg(1,1,iii))
7098       enddo
7099 cd      if (lprn) write (2,*) 'In kernel'
7100       do kkk=1,5
7101 cd        if (lprn) write (2,*) 'kkk=',kkk
7102         do lll=1,3
7103           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7104      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7105 cd          if (lprn) then
7106 cd            write (2,*) 'lll=',lll
7107 cd            write (2,*) 'iii=1'
7108 cd            do jjj=1,2
7109 cd              write (2,'(3(2f10.5),5x)')
7110 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7111 cd            enddo
7112 cd          endif
7113           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7114      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7115 cd          if (lprn) then
7116 cd            write (2,*) 'lll=',lll
7117 cd            write (2,*) 'iii=2'
7118 cd            do jjj=1,2
7119 cd              write (2,'(3(2f10.5),5x)')
7120 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7121 cd            enddo
7122 cd          endif
7123         enddo
7124       enddo
7125       return
7126       end
7127 C---------------------------------------------------------------------------
7128       double precision function eello4(i,j,k,l,jj,kk)
7129       implicit real*8 (a-h,o-z)
7130       include 'DIMENSIONS'
7131       include 'COMMON.IOUNITS'
7132       include 'COMMON.CHAIN'
7133       include 'COMMON.DERIV'
7134       include 'COMMON.INTERACT'
7135       include 'COMMON.CONTACTS'
7136       include 'COMMON.TORSION'
7137       include 'COMMON.VAR'
7138       include 'COMMON.GEO'
7139       double precision pizda(2,2),ggg1(3),ggg2(3)
7140 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7141 cd        eello4=0.0d0
7142 cd        return
7143 cd      endif
7144 cd      print *,'eello4:',i,j,k,l,jj,kk
7145 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7146 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7147 cold      eij=facont_hb(jj,i)
7148 cold      ekl=facont_hb(kk,k)
7149 cold      ekont=eij*ekl
7150       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7151 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7152       gcorr_loc(k-1)=gcorr_loc(k-1)
7153      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7154       if (l.eq.j+1) then
7155         gcorr_loc(l-1)=gcorr_loc(l-1)
7156      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7157       else
7158         gcorr_loc(j-1)=gcorr_loc(j-1)
7159      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7160       endif
7161       do iii=1,2
7162         do kkk=1,5
7163           do lll=1,3
7164             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7165      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7166 cd            derx(lll,kkk,iii)=0.0d0
7167           enddo
7168         enddo
7169       enddo
7170 cd      gcorr_loc(l-1)=0.0d0
7171 cd      gcorr_loc(j-1)=0.0d0
7172 cd      gcorr_loc(k-1)=0.0d0
7173 cd      eel4=1.0d0
7174 cd      write (iout,*)'Contacts have occurred for peptide groups',
7175 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7176 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7177       if (j.lt.nres-1) then
7178         j1=j+1
7179         j2=j-1
7180       else
7181         j1=j-1
7182         j2=j-2
7183       endif
7184       if (l.lt.nres-1) then
7185         l1=l+1
7186         l2=l-1
7187       else
7188         l1=l-1
7189         l2=l-2
7190       endif
7191       do ll=1,3
7192 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7193 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7194         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7195         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7196 cgrad        ghalf=0.5d0*ggg1(ll)
7197         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7198         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7199         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7200         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7201         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7202         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7203 cgrad        ghalf=0.5d0*ggg2(ll)
7204         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7205         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7206         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7207         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7208         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7209         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7210       enddo
7211 cgrad      do m=i+1,j-1
7212 cgrad        do ll=1,3
7213 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7214 cgrad        enddo
7215 cgrad      enddo
7216 cgrad      do m=k+1,l-1
7217 cgrad        do ll=1,3
7218 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7219 cgrad        enddo
7220 cgrad      enddo
7221 cgrad      do m=i+2,j2
7222 cgrad        do ll=1,3
7223 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7224 cgrad        enddo
7225 cgrad      enddo
7226 cgrad      do m=k+2,l2
7227 cgrad        do ll=1,3
7228 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7229 cgrad        enddo
7230 cgrad      enddo
7231 cd      do iii=1,nres-3
7232 cd        write (2,*) iii,gcorr_loc(iii)
7233 cd      enddo
7234       eello4=ekont*eel4
7235 cd      write (2,*) 'ekont',ekont
7236 cd      write (iout,*) 'eello4',ekont*eel4
7237       return
7238       end
7239 C---------------------------------------------------------------------------
7240       double precision function eello5(i,j,k,l,jj,kk)
7241       implicit real*8 (a-h,o-z)
7242       include 'DIMENSIONS'
7243       include 'COMMON.IOUNITS'
7244       include 'COMMON.CHAIN'
7245       include 'COMMON.DERIV'
7246       include 'COMMON.INTERACT'
7247       include 'COMMON.CONTACTS'
7248       include 'COMMON.TORSION'
7249       include 'COMMON.VAR'
7250       include 'COMMON.GEO'
7251       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7252       double precision ggg1(3),ggg2(3)
7253 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7254 C                                                                              C
7255 C                            Parallel chains                                   C
7256 C                                                                              C
7257 C          o             o                   o             o                   C
7258 C         /l\           / \             \   / \           / \   /              C
7259 C        /   \         /   \             \ /   \         /   \ /               C
7260 C       j| o |l1       | o |              o| o |         | o |o                C
7261 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7262 C      \i/   \         /   \ /             /   \         /   \                 C
7263 C       o    k1             o                                                  C
7264 C         (I)          (II)                (III)          (IV)                 C
7265 C                                                                              C
7266 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7267 C                                                                              C
7268 C                            Antiparallel chains                               C
7269 C                                                                              C
7270 C          o             o                   o             o                   C
7271 C         /j\           / \             \   / \           / \   /              C
7272 C        /   \         /   \             \ /   \         /   \ /               C
7273 C      j1| o |l        | o |              o| o |         | o |o                C
7274 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7275 C      \i/   \         /   \ /             /   \         /   \                 C
7276 C       o     k1            o                                                  C
7277 C         (I)          (II)                (III)          (IV)                 C
7278 C                                                                              C
7279 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7280 C                                                                              C
7281 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7282 C                                                                              C
7283 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7284 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7285 cd        eello5=0.0d0
7286 cd        return
7287 cd      endif
7288 cd      write (iout,*)
7289 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7290 cd     &   ' and',k,l
7291       itk=itortyp(itype(k))
7292       itl=itortyp(itype(l))
7293       itj=itortyp(itype(j))
7294       eello5_1=0.0d0
7295       eello5_2=0.0d0
7296       eello5_3=0.0d0
7297       eello5_4=0.0d0
7298 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7299 cd     &   eel5_3_num,eel5_4_num)
7300       do iii=1,2
7301         do kkk=1,5
7302           do lll=1,3
7303             derx(lll,kkk,iii)=0.0d0
7304           enddo
7305         enddo
7306       enddo
7307 cd      eij=facont_hb(jj,i)
7308 cd      ekl=facont_hb(kk,k)
7309 cd      ekont=eij*ekl
7310 cd      write (iout,*)'Contacts have occurred for peptide groups',
7311 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7312 cd      goto 1111
7313 C Contribution from the graph I.
7314 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7315 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7316       call transpose2(EUg(1,1,k),auxmat(1,1))
7317       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7318       vv(1)=pizda(1,1)-pizda(2,2)
7319       vv(2)=pizda(1,2)+pizda(2,1)
7320       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7321      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7322 C Explicit gradient in virtual-dihedral angles.
7323       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7324      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7325      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7326       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7327       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7328       vv(1)=pizda(1,1)-pizda(2,2)
7329       vv(2)=pizda(1,2)+pizda(2,1)
7330       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7331      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7332      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7333       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7334       vv(1)=pizda(1,1)-pizda(2,2)
7335       vv(2)=pizda(1,2)+pizda(2,1)
7336       if (l.eq.j+1) then
7337         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7338      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7339      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7340       else
7341         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7342      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7343      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7344       endif
7345 C Cartesian gradient
7346       do iii=1,2
7347         do kkk=1,5
7348           do lll=1,3
7349             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7350      &        pizda(1,1))
7351             vv(1)=pizda(1,1)-pizda(2,2)
7352             vv(2)=pizda(1,2)+pizda(2,1)
7353             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7354      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7355      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7356           enddo
7357         enddo
7358       enddo
7359 c      goto 1112
7360 c1111  continue
7361 C Contribution from graph II
7362       call transpose2(EE(1,1,itk),auxmat(1,1))
7363       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7364       vv(1)=pizda(1,1)+pizda(2,2)
7365       vv(2)=pizda(2,1)-pizda(1,2)
7366       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7367      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7368 C Explicit gradient in virtual-dihedral angles.
7369       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7370      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7371       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7372       vv(1)=pizda(1,1)+pizda(2,2)
7373       vv(2)=pizda(2,1)-pizda(1,2)
7374       if (l.eq.j+1) then
7375         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7376      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7377      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7378       else
7379         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7380      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7381      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7382       endif
7383 C Cartesian gradient
7384       do iii=1,2
7385         do kkk=1,5
7386           do lll=1,3
7387             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7388      &        pizda(1,1))
7389             vv(1)=pizda(1,1)+pizda(2,2)
7390             vv(2)=pizda(2,1)-pizda(1,2)
7391             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7392      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7393      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7394           enddo
7395         enddo
7396       enddo
7397 cd      goto 1112
7398 cd1111  continue
7399       if (l.eq.j+1) then
7400 cd        goto 1110
7401 C Parallel orientation
7402 C Contribution from graph III
7403         call transpose2(EUg(1,1,l),auxmat(1,1))
7404         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7405         vv(1)=pizda(1,1)-pizda(2,2)
7406         vv(2)=pizda(1,2)+pizda(2,1)
7407         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7408      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7409 C Explicit gradient in virtual-dihedral angles.
7410         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7411      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7412      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7413         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7414         vv(1)=pizda(1,1)-pizda(2,2)
7415         vv(2)=pizda(1,2)+pizda(2,1)
7416         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7417      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7418      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7419         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7420         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7421         vv(1)=pizda(1,1)-pizda(2,2)
7422         vv(2)=pizda(1,2)+pizda(2,1)
7423         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7424      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7425      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7426 C Cartesian gradient
7427         do iii=1,2
7428           do kkk=1,5
7429             do lll=1,3
7430               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7431      &          pizda(1,1))
7432               vv(1)=pizda(1,1)-pizda(2,2)
7433               vv(2)=pizda(1,2)+pizda(2,1)
7434               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7435      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7436      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7437             enddo
7438           enddo
7439         enddo
7440 cd        goto 1112
7441 C Contribution from graph IV
7442 cd1110    continue
7443         call transpose2(EE(1,1,itl),auxmat(1,1))
7444         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7445         vv(1)=pizda(1,1)+pizda(2,2)
7446         vv(2)=pizda(2,1)-pizda(1,2)
7447         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7448      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7449 C Explicit gradient in virtual-dihedral angles.
7450         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7451      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7452         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7453         vv(1)=pizda(1,1)+pizda(2,2)
7454         vv(2)=pizda(2,1)-pizda(1,2)
7455         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7456      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7457      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7458 C Cartesian gradient
7459         do iii=1,2
7460           do kkk=1,5
7461             do lll=1,3
7462               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7463      &          pizda(1,1))
7464               vv(1)=pizda(1,1)+pizda(2,2)
7465               vv(2)=pizda(2,1)-pizda(1,2)
7466               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7467      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7468      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7469             enddo
7470           enddo
7471         enddo
7472       else
7473 C Antiparallel orientation
7474 C Contribution from graph III
7475 c        goto 1110
7476         call transpose2(EUg(1,1,j),auxmat(1,1))
7477         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7478         vv(1)=pizda(1,1)-pizda(2,2)
7479         vv(2)=pizda(1,2)+pizda(2,1)
7480         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7481      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7482 C Explicit gradient in virtual-dihedral angles.
7483         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7484      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7485      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7486         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7487         vv(1)=pizda(1,1)-pizda(2,2)
7488         vv(2)=pizda(1,2)+pizda(2,1)
7489         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7490      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7491      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7492         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7493         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7494         vv(1)=pizda(1,1)-pizda(2,2)
7495         vv(2)=pizda(1,2)+pizda(2,1)
7496         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7497      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7498      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7499 C Cartesian gradient
7500         do iii=1,2
7501           do kkk=1,5
7502             do lll=1,3
7503               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7504      &          pizda(1,1))
7505               vv(1)=pizda(1,1)-pizda(2,2)
7506               vv(2)=pizda(1,2)+pizda(2,1)
7507               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7508      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7509      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7510             enddo
7511           enddo
7512         enddo
7513 cd        goto 1112
7514 C Contribution from graph IV
7515 1110    continue
7516         call transpose2(EE(1,1,itj),auxmat(1,1))
7517         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7518         vv(1)=pizda(1,1)+pizda(2,2)
7519         vv(2)=pizda(2,1)-pizda(1,2)
7520         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7521      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7522 C Explicit gradient in virtual-dihedral angles.
7523         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7524      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7525         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7526         vv(1)=pizda(1,1)+pizda(2,2)
7527         vv(2)=pizda(2,1)-pizda(1,2)
7528         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7529      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7530      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7531 C Cartesian gradient
7532         do iii=1,2
7533           do kkk=1,5
7534             do lll=1,3
7535               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7536      &          pizda(1,1))
7537               vv(1)=pizda(1,1)+pizda(2,2)
7538               vv(2)=pizda(2,1)-pizda(1,2)
7539               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7540      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7541      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7542             enddo
7543           enddo
7544         enddo
7545       endif
7546 1112  continue
7547       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7548 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7549 cd        write (2,*) 'ijkl',i,j,k,l
7550 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7551 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7552 cd      endif
7553 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7554 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7555 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7556 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7557       if (j.lt.nres-1) then
7558         j1=j+1
7559         j2=j-1
7560       else
7561         j1=j-1
7562         j2=j-2
7563       endif
7564       if (l.lt.nres-1) then
7565         l1=l+1
7566         l2=l-1
7567       else
7568         l1=l-1
7569         l2=l-2
7570       endif
7571 cd      eij=1.0d0
7572 cd      ekl=1.0d0
7573 cd      ekont=1.0d0
7574 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7575 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7576 C        summed up outside the subrouine as for the other subroutines
7577 C        handling long-range interactions. The old code is commented out
7578 C        with "cgrad" to keep track of changes.
7579       do ll=1,3
7580 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7581 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7582         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7583         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7584 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7585 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7586 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7587 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7588 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7589 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7590 c     &   gradcorr5ij,
7591 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7592 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7593 cgrad        ghalf=0.5d0*ggg1(ll)
7594 cd        ghalf=0.0d0
7595         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7596         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7597         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7598         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7599         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7600         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7601 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7602 cgrad        ghalf=0.5d0*ggg2(ll)
7603 cd        ghalf=0.0d0
7604         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7605         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7606         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7607         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7608         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7609         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7610       enddo
7611 cd      goto 1112
7612 cgrad      do m=i+1,j-1
7613 cgrad        do ll=1,3
7614 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7615 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7616 cgrad        enddo
7617 cgrad      enddo
7618 cgrad      do m=k+1,l-1
7619 cgrad        do ll=1,3
7620 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7621 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7622 cgrad        enddo
7623 cgrad      enddo
7624 c1112  continue
7625 cgrad      do m=i+2,j2
7626 cgrad        do ll=1,3
7627 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7628 cgrad        enddo
7629 cgrad      enddo
7630 cgrad      do m=k+2,l2
7631 cgrad        do ll=1,3
7632 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7633 cgrad        enddo
7634 cgrad      enddo
7635 cd      do iii=1,nres-3
7636 cd        write (2,*) iii,g_corr5_loc(iii)
7637 cd      enddo
7638       eello5=ekont*eel5
7639 cd      write (2,*) 'ekont',ekont
7640 cd      write (iout,*) 'eello5',ekont*eel5
7641       return
7642       end
7643 c--------------------------------------------------------------------------
7644       double precision function eello6(i,j,k,l,jj,kk)
7645       implicit real*8 (a-h,o-z)
7646       include 'DIMENSIONS'
7647       include 'COMMON.IOUNITS'
7648       include 'COMMON.CHAIN'
7649       include 'COMMON.DERIV'
7650       include 'COMMON.INTERACT'
7651       include 'COMMON.CONTACTS'
7652       include 'COMMON.TORSION'
7653       include 'COMMON.VAR'
7654       include 'COMMON.GEO'
7655       include 'COMMON.FFIELD'
7656       double precision ggg1(3),ggg2(3)
7657 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7658 cd        eello6=0.0d0
7659 cd        return
7660 cd      endif
7661 cd      write (iout,*)
7662 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7663 cd     &   ' and',k,l
7664       eello6_1=0.0d0
7665       eello6_2=0.0d0
7666       eello6_3=0.0d0
7667       eello6_4=0.0d0
7668       eello6_5=0.0d0
7669       eello6_6=0.0d0
7670 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7671 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7672       do iii=1,2
7673         do kkk=1,5
7674           do lll=1,3
7675             derx(lll,kkk,iii)=0.0d0
7676           enddo
7677         enddo
7678       enddo
7679 cd      eij=facont_hb(jj,i)
7680 cd      ekl=facont_hb(kk,k)
7681 cd      ekont=eij*ekl
7682 cd      eij=1.0d0
7683 cd      ekl=1.0d0
7684 cd      ekont=1.0d0
7685       if (l.eq.j+1) then
7686         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7687         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7688         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7689         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7690         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7691         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7692       else
7693         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7694         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7695         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7696         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7697         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7698           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7699         else
7700           eello6_5=0.0d0
7701         endif
7702         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7703       endif
7704 C If turn contributions are considered, they will be handled separately.
7705       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7706 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7707 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7708 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7709 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7710 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7711 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7712 cd      goto 1112
7713       if (j.lt.nres-1) then
7714         j1=j+1
7715         j2=j-1
7716       else
7717         j1=j-1
7718         j2=j-2
7719       endif
7720       if (l.lt.nres-1) then
7721         l1=l+1
7722         l2=l-1
7723       else
7724         l1=l-1
7725         l2=l-2
7726       endif
7727       do ll=1,3
7728 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7729 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7730 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7731 cgrad        ghalf=0.5d0*ggg1(ll)
7732 cd        ghalf=0.0d0
7733         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7734         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7735         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7736         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7737         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7738         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7739         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7740         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7741 cgrad        ghalf=0.5d0*ggg2(ll)
7742 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7743 cd        ghalf=0.0d0
7744         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7745         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7746         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7747         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7748         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7749         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7750       enddo
7751 cd      goto 1112
7752 cgrad      do m=i+1,j-1
7753 cgrad        do ll=1,3
7754 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7755 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7756 cgrad        enddo
7757 cgrad      enddo
7758 cgrad      do m=k+1,l-1
7759 cgrad        do ll=1,3
7760 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7761 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7762 cgrad        enddo
7763 cgrad      enddo
7764 cgrad1112  continue
7765 cgrad      do m=i+2,j2
7766 cgrad        do ll=1,3
7767 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7768 cgrad        enddo
7769 cgrad      enddo
7770 cgrad      do m=k+2,l2
7771 cgrad        do ll=1,3
7772 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7773 cgrad        enddo
7774 cgrad      enddo
7775 cd      do iii=1,nres-3
7776 cd        write (2,*) iii,g_corr6_loc(iii)
7777 cd      enddo
7778       eello6=ekont*eel6
7779 cd      write (2,*) 'ekont',ekont
7780 cd      write (iout,*) 'eello6',ekont*eel6
7781       return
7782       end
7783 c--------------------------------------------------------------------------
7784       double precision function eello6_graph1(i,j,k,l,imat,swap)
7785       implicit real*8 (a-h,o-z)
7786       include 'DIMENSIONS'
7787       include 'COMMON.IOUNITS'
7788       include 'COMMON.CHAIN'
7789       include 'COMMON.DERIV'
7790       include 'COMMON.INTERACT'
7791       include 'COMMON.CONTACTS'
7792       include 'COMMON.TORSION'
7793       include 'COMMON.VAR'
7794       include 'COMMON.GEO'
7795       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7796       logical swap
7797       logical lprn
7798       common /kutas/ lprn
7799 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7800 C                                                                              C
7801 C      Parallel       Antiparallel                                             C
7802 C                                                                              C
7803 C          o             o                                                     C
7804 C         /l\           /j\                                                    C
7805 C        /   \         /   \                                                   C
7806 C       /| o |         | o |\                                                  C
7807 C     \ j|/k\|  /   \  |/k\|l /                                                C
7808 C      \ /   \ /     \ /   \ /                                                 C
7809 C       o     o       o     o                                                  C
7810 C       i             i                                                        C
7811 C                                                                              C
7812 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7813       itk=itortyp(itype(k))
7814       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7815       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7816       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7817       call transpose2(EUgC(1,1,k),auxmat(1,1))
7818       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7819       vv1(1)=pizda1(1,1)-pizda1(2,2)
7820       vv1(2)=pizda1(1,2)+pizda1(2,1)
7821       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7822       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7823       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7824       s5=scalar2(vv(1),Dtobr2(1,i))
7825 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7826       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7827       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7828      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7829      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7830      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7831      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7832      & +scalar2(vv(1),Dtobr2der(1,i)))
7833       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7834       vv1(1)=pizda1(1,1)-pizda1(2,2)
7835       vv1(2)=pizda1(1,2)+pizda1(2,1)
7836       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7837       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7838       if (l.eq.j+1) then
7839         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7840      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7841      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7842      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7843      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7844       else
7845         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7846      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7847      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7848      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7849      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7850       endif
7851       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7852       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7853       vv1(1)=pizda1(1,1)-pizda1(2,2)
7854       vv1(2)=pizda1(1,2)+pizda1(2,1)
7855       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7856      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7857      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7858      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7859       do iii=1,2
7860         if (swap) then
7861           ind=3-iii
7862         else
7863           ind=iii
7864         endif
7865         do kkk=1,5
7866           do lll=1,3
7867             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7868             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7869             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7870             call transpose2(EUgC(1,1,k),auxmat(1,1))
7871             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7872      &        pizda1(1,1))
7873             vv1(1)=pizda1(1,1)-pizda1(2,2)
7874             vv1(2)=pizda1(1,2)+pizda1(2,1)
7875             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7876             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7877      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7878             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7879      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7880             s5=scalar2(vv(1),Dtobr2(1,i))
7881             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7882           enddo
7883         enddo
7884       enddo
7885       return
7886       end
7887 c----------------------------------------------------------------------------
7888       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7889       implicit real*8 (a-h,o-z)
7890       include 'DIMENSIONS'
7891       include 'COMMON.IOUNITS'
7892       include 'COMMON.CHAIN'
7893       include 'COMMON.DERIV'
7894       include 'COMMON.INTERACT'
7895       include 'COMMON.CONTACTS'
7896       include 'COMMON.TORSION'
7897       include 'COMMON.VAR'
7898       include 'COMMON.GEO'
7899       logical swap
7900       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7901      & auxvec1(2),auxvec2(1),auxmat1(2,2)
7902       logical lprn
7903       common /kutas/ lprn
7904 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7905 C                                                                              C
7906 C      Parallel       Antiparallel                                             C
7907 C                                                                              C
7908 C          o             o                                                     C
7909 C     \   /l\           /j\   /                                                C
7910 C      \ /   \         /   \ /                                                 C
7911 C       o| o |         | o |o                                                  C
7912 C     \ j|/k\|      \  |/k\|l                                                  C
7913 C      \ /   \       \ /   \                                                   C
7914 C       o             o                                                        C
7915 C       i             i                                                        C
7916 C                                                                              C
7917 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7918 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7919 C AL 7/4/01 s1 would occur in the sixth-order moment,
7920 C           but not in a cluster cumulant
7921 #ifdef MOMENT
7922       s1=dip(1,jj,i)*dip(1,kk,k)
7923 #endif
7924       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7925       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7926       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7927       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7928       call transpose2(EUg(1,1,k),auxmat(1,1))
7929       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7930       vv(1)=pizda(1,1)-pizda(2,2)
7931       vv(2)=pizda(1,2)+pizda(2,1)
7932       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7933 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7934 #ifdef MOMENT
7935       eello6_graph2=-(s1+s2+s3+s4)
7936 #else
7937       eello6_graph2=-(s2+s3+s4)
7938 #endif
7939 c      eello6_graph2=-s3
7940 C Derivatives in gamma(i-1)
7941       if (i.gt.1) then
7942 #ifdef MOMENT
7943         s1=dipderg(1,jj,i)*dip(1,kk,k)
7944 #endif
7945         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7946         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7947         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7948         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7949 #ifdef MOMENT
7950         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7951 #else
7952         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7953 #endif
7954 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7955       endif
7956 C Derivatives in gamma(k-1)
7957 #ifdef MOMENT
7958       s1=dip(1,jj,i)*dipderg(1,kk,k)
7959 #endif
7960       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7961       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7962       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7963       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7964       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7965       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7966       vv(1)=pizda(1,1)-pizda(2,2)
7967       vv(2)=pizda(1,2)+pizda(2,1)
7968       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7969 #ifdef MOMENT
7970       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7971 #else
7972       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7973 #endif
7974 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7975 C Derivatives in gamma(j-1) or gamma(l-1)
7976       if (j.gt.1) then
7977 #ifdef MOMENT
7978         s1=dipderg(3,jj,i)*dip(1,kk,k)
7979 #endif
7980         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7981         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7982         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7983         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7984         vv(1)=pizda(1,1)-pizda(2,2)
7985         vv(2)=pizda(1,2)+pizda(2,1)
7986         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7987 #ifdef MOMENT
7988         if (swap) then
7989           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7990         else
7991           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7992         endif
7993 #endif
7994         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7995 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7996       endif
7997 C Derivatives in gamma(l-1) or gamma(j-1)
7998       if (l.gt.1) then
7999 #ifdef MOMENT
8000         s1=dip(1,jj,i)*dipderg(3,kk,k)
8001 #endif
8002         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8003         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8004         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8005         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8006         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8007         vv(1)=pizda(1,1)-pizda(2,2)
8008         vv(2)=pizda(1,2)+pizda(2,1)
8009         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8010 #ifdef MOMENT
8011         if (swap) then
8012           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8013         else
8014           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8015         endif
8016 #endif
8017         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8018 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8019       endif
8020 C Cartesian derivatives.
8021       if (lprn) then
8022         write (2,*) 'In eello6_graph2'
8023         do iii=1,2
8024           write (2,*) 'iii=',iii
8025           do kkk=1,5
8026             write (2,*) 'kkk=',kkk
8027             do jjj=1,2
8028               write (2,'(3(2f10.5),5x)')
8029      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8030             enddo
8031           enddo
8032         enddo
8033       endif
8034       do iii=1,2
8035         do kkk=1,5
8036           do lll=1,3
8037 #ifdef MOMENT
8038             if (iii.eq.1) then
8039               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8040             else
8041               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8042             endif
8043 #endif
8044             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8045      &        auxvec(1))
8046             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8047             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8048      &        auxvec(1))
8049             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8050             call transpose2(EUg(1,1,k),auxmat(1,1))
8051             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8052      &        pizda(1,1))
8053             vv(1)=pizda(1,1)-pizda(2,2)
8054             vv(2)=pizda(1,2)+pizda(2,1)
8055             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8056 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8057 #ifdef MOMENT
8058             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8059 #else
8060             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8061 #endif
8062             if (swap) then
8063               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8064             else
8065               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8066             endif
8067           enddo
8068         enddo
8069       enddo
8070       return
8071       end
8072 c----------------------------------------------------------------------------
8073       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8074       implicit real*8 (a-h,o-z)
8075       include 'DIMENSIONS'
8076       include 'COMMON.IOUNITS'
8077       include 'COMMON.CHAIN'
8078       include 'COMMON.DERIV'
8079       include 'COMMON.INTERACT'
8080       include 'COMMON.CONTACTS'
8081       include 'COMMON.TORSION'
8082       include 'COMMON.VAR'
8083       include 'COMMON.GEO'
8084       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8085       logical swap
8086 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8087 C                                                                              C
8088 C      Parallel       Antiparallel                                             C
8089 C                                                                              C
8090 C          o             o                                                     C
8091 C         /l\   /   \   /j\                                                    C
8092 C        /   \ /     \ /   \                                                   C
8093 C       /| o |o       o| o |\                                                  C
8094 C       j|/k\|  /      |/k\|l /                                                C
8095 C        /   \ /       /   \ /                                                 C
8096 C       /     o       /     o                                                  C
8097 C       i             i                                                        C
8098 C                                                                              C
8099 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8100 C
8101 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8102 C           energy moment and not to the cluster cumulant.
8103       iti=itortyp(itype(i))
8104       if (j.lt.nres-1) then
8105         itj1=itortyp(itype(j+1))
8106       else
8107         itj1=ntortyp+1
8108       endif
8109       itk=itortyp(itype(k))
8110       itk1=itortyp(itype(k+1))
8111       if (l.lt.nres-1) then
8112         itl1=itortyp(itype(l+1))
8113       else
8114         itl1=ntortyp+1
8115       endif
8116 #ifdef MOMENT
8117       s1=dip(4,jj,i)*dip(4,kk,k)
8118 #endif
8119       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8120       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8121       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8122       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8123       call transpose2(EE(1,1,itk),auxmat(1,1))
8124       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8125       vv(1)=pizda(1,1)+pizda(2,2)
8126       vv(2)=pizda(2,1)-pizda(1,2)
8127       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8128 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8129 cd     & "sum",-(s2+s3+s4)
8130 #ifdef MOMENT
8131       eello6_graph3=-(s1+s2+s3+s4)
8132 #else
8133       eello6_graph3=-(s2+s3+s4)
8134 #endif
8135 c      eello6_graph3=-s4
8136 C Derivatives in gamma(k-1)
8137       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8138       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8139       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8140       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8141 C Derivatives in gamma(l-1)
8142       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8143       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8144       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8145       vv(1)=pizda(1,1)+pizda(2,2)
8146       vv(2)=pizda(2,1)-pizda(1,2)
8147       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8148       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8149 C Cartesian derivatives.
8150       do iii=1,2
8151         do kkk=1,5
8152           do lll=1,3
8153 #ifdef MOMENT
8154             if (iii.eq.1) then
8155               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8156             else
8157               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8158             endif
8159 #endif
8160             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8161      &        auxvec(1))
8162             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8163             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8164      &        auxvec(1))
8165             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8166             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8167      &        pizda(1,1))
8168             vv(1)=pizda(1,1)+pizda(2,2)
8169             vv(2)=pizda(2,1)-pizda(1,2)
8170             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8171 #ifdef MOMENT
8172             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8173 #else
8174             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8175 #endif
8176             if (swap) then
8177               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8178             else
8179               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8180             endif
8181 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8182           enddo
8183         enddo
8184       enddo
8185       return
8186       end
8187 c----------------------------------------------------------------------------
8188       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8189       implicit real*8 (a-h,o-z)
8190       include 'DIMENSIONS'
8191       include 'COMMON.IOUNITS'
8192       include 'COMMON.CHAIN'
8193       include 'COMMON.DERIV'
8194       include 'COMMON.INTERACT'
8195       include 'COMMON.CONTACTS'
8196       include 'COMMON.TORSION'
8197       include 'COMMON.VAR'
8198       include 'COMMON.GEO'
8199       include 'COMMON.FFIELD'
8200       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8201      & auxvec1(2),auxmat1(2,2)
8202       logical swap
8203 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8204 C                                                                              C
8205 C      Parallel       Antiparallel                                             C
8206 C                                                                              C
8207 C          o             o                                                     C
8208 C         /l\   /   \   /j\                                                    C
8209 C        /   \ /     \ /   \                                                   C
8210 C       /| o |o       o| o |\                                                  C
8211 C     \ j|/k\|      \  |/k\|l                                                  C
8212 C      \ /   \       \ /   \                                                   C
8213 C       o     \       o     \                                                  C
8214 C       i             i                                                        C
8215 C                                                                              C
8216 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8217 C
8218 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8219 C           energy moment and not to the cluster cumulant.
8220 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8221       iti=itortyp(itype(i))
8222       itj=itortyp(itype(j))
8223       if (j.lt.nres-1) then
8224         itj1=itortyp(itype(j+1))
8225       else
8226         itj1=ntortyp+1
8227       endif
8228       itk=itortyp(itype(k))
8229       if (k.lt.nres-1) then
8230         itk1=itortyp(itype(k+1))
8231       else
8232         itk1=ntortyp+1
8233       endif
8234       itl=itortyp(itype(l))
8235       if (l.lt.nres-1) then
8236         itl1=itortyp(itype(l+1))
8237       else
8238         itl1=ntortyp+1
8239       endif
8240 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8241 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8242 cd     & ' itl',itl,' itl1',itl1
8243 #ifdef MOMENT
8244       if (imat.eq.1) then
8245         s1=dip(3,jj,i)*dip(3,kk,k)
8246       else
8247         s1=dip(2,jj,j)*dip(2,kk,l)
8248       endif
8249 #endif
8250       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8251       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8252       if (j.eq.l+1) then
8253         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8254         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8255       else
8256         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8257         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8258       endif
8259       call transpose2(EUg(1,1,k),auxmat(1,1))
8260       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8261       vv(1)=pizda(1,1)-pizda(2,2)
8262       vv(2)=pizda(2,1)+pizda(1,2)
8263       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8264 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8265 #ifdef MOMENT
8266       eello6_graph4=-(s1+s2+s3+s4)
8267 #else
8268       eello6_graph4=-(s2+s3+s4)
8269 #endif
8270 C Derivatives in gamma(i-1)
8271       if (i.gt.1) then
8272 #ifdef MOMENT
8273         if (imat.eq.1) then
8274           s1=dipderg(2,jj,i)*dip(3,kk,k)
8275         else
8276           s1=dipderg(4,jj,j)*dip(2,kk,l)
8277         endif
8278 #endif
8279         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8280         if (j.eq.l+1) then
8281           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8282           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8283         else
8284           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8285           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8286         endif
8287         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8288         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8289 cd          write (2,*) 'turn6 derivatives'
8290 #ifdef MOMENT
8291           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8292 #else
8293           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8294 #endif
8295         else
8296 #ifdef MOMENT
8297           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8298 #else
8299           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8300 #endif
8301         endif
8302       endif
8303 C Derivatives in gamma(k-1)
8304 #ifdef MOMENT
8305       if (imat.eq.1) then
8306         s1=dip(3,jj,i)*dipderg(2,kk,k)
8307       else
8308         s1=dip(2,jj,j)*dipderg(4,kk,l)
8309       endif
8310 #endif
8311       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8312       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8313       if (j.eq.l+1) then
8314         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8315         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8316       else
8317         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8318         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8319       endif
8320       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8321       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8322       vv(1)=pizda(1,1)-pizda(2,2)
8323       vv(2)=pizda(2,1)+pizda(1,2)
8324       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8325       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8326 #ifdef MOMENT
8327         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8328 #else
8329         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8330 #endif
8331       else
8332 #ifdef MOMENT
8333         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8334 #else
8335         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8336 #endif
8337       endif
8338 C Derivatives in gamma(j-1) or gamma(l-1)
8339       if (l.eq.j+1 .and. l.gt.1) then
8340         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8341         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8342         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8343         vv(1)=pizda(1,1)-pizda(2,2)
8344         vv(2)=pizda(2,1)+pizda(1,2)
8345         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8346         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8347       else if (j.gt.1) then
8348         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8349         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8350         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8351         vv(1)=pizda(1,1)-pizda(2,2)
8352         vv(2)=pizda(2,1)+pizda(1,2)
8353         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8354         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8355           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8356         else
8357           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8358         endif
8359       endif
8360 C Cartesian derivatives.
8361       do iii=1,2
8362         do kkk=1,5
8363           do lll=1,3
8364 #ifdef MOMENT
8365             if (iii.eq.1) then
8366               if (imat.eq.1) then
8367                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8368               else
8369                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8370               endif
8371             else
8372               if (imat.eq.1) then
8373                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8374               else
8375                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8376               endif
8377             endif
8378 #endif
8379             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8380      &        auxvec(1))
8381             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8382             if (j.eq.l+1) then
8383               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8384      &          b1(1,itj1),auxvec(1))
8385               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8386             else
8387               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8388      &          b1(1,itl1),auxvec(1))
8389               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8390             endif
8391             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8392      &        pizda(1,1))
8393             vv(1)=pizda(1,1)-pizda(2,2)
8394             vv(2)=pizda(2,1)+pizda(1,2)
8395             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8396             if (swap) then
8397               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8398 #ifdef MOMENT
8399                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8400      &             -(s1+s2+s4)
8401 #else
8402                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8403      &             -(s2+s4)
8404 #endif
8405                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8406               else
8407 #ifdef MOMENT
8408                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8409 #else
8410                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8411 #endif
8412                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8413               endif
8414             else
8415 #ifdef MOMENT
8416               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8417 #else
8418               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8419 #endif
8420               if (l.eq.j+1) then
8421                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8422               else
8423                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8424               endif
8425             endif
8426           enddo
8427         enddo
8428       enddo
8429       return
8430       end
8431 c----------------------------------------------------------------------------
8432       double precision function eello_turn6(i,jj,kk)
8433       implicit real*8 (a-h,o-z)
8434       include 'DIMENSIONS'
8435       include 'COMMON.IOUNITS'
8436       include 'COMMON.CHAIN'
8437       include 'COMMON.DERIV'
8438       include 'COMMON.INTERACT'
8439       include 'COMMON.CONTACTS'
8440       include 'COMMON.TORSION'
8441       include 'COMMON.VAR'
8442       include 'COMMON.GEO'
8443       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8444      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8445      &  ggg1(3),ggg2(3)
8446       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8447      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8448 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8449 C           the respective energy moment and not to the cluster cumulant.
8450       s1=0.0d0
8451       s8=0.0d0
8452       s13=0.0d0
8453 c
8454       eello_turn6=0.0d0
8455       j=i+4
8456       k=i+1
8457       l=i+3
8458       iti=itortyp(itype(i))
8459       itk=itortyp(itype(k))
8460       itk1=itortyp(itype(k+1))
8461       itl=itortyp(itype(l))
8462       itj=itortyp(itype(j))
8463 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8464 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8465 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8466 cd        eello6=0.0d0
8467 cd        return
8468 cd      endif
8469 cd      write (iout,*)
8470 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8471 cd     &   ' and',k,l
8472 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8473       do iii=1,2
8474         do kkk=1,5
8475           do lll=1,3
8476             derx_turn(lll,kkk,iii)=0.0d0
8477           enddo
8478         enddo
8479       enddo
8480 cd      eij=1.0d0
8481 cd      ekl=1.0d0
8482 cd      ekont=1.0d0
8483       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8484 cd      eello6_5=0.0d0
8485 cd      write (2,*) 'eello6_5',eello6_5
8486 #ifdef MOMENT
8487       call transpose2(AEA(1,1,1),auxmat(1,1))
8488       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8489       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8490       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8491 #endif
8492       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8493       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8494       s2 = scalar2(b1(1,itk),vtemp1(1))
8495 #ifdef MOMENT
8496       call transpose2(AEA(1,1,2),atemp(1,1))
8497       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8498       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8499       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8500 #endif
8501       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8502       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8503       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8504 #ifdef MOMENT
8505       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8506       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8507       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8508       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8509       ss13 = scalar2(b1(1,itk),vtemp4(1))
8510       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8511 #endif
8512 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8513 c      s1=0.0d0
8514 c      s2=0.0d0
8515 c      s8=0.0d0
8516 c      s12=0.0d0
8517 c      s13=0.0d0
8518       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8519 C Derivatives in gamma(i+2)
8520       s1d =0.0d0
8521       s8d =0.0d0
8522 #ifdef MOMENT
8523       call transpose2(AEA(1,1,1),auxmatd(1,1))
8524       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8525       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8526       call transpose2(AEAderg(1,1,2),atempd(1,1))
8527       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8528       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8529 #endif
8530       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8531       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8532       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8533 c      s1d=0.0d0
8534 c      s2d=0.0d0
8535 c      s8d=0.0d0
8536 c      s12d=0.0d0
8537 c      s13d=0.0d0
8538       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8539 C Derivatives in gamma(i+3)
8540 #ifdef MOMENT
8541       call transpose2(AEA(1,1,1),auxmatd(1,1))
8542       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8543       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8544       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8545 #endif
8546       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8547       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8548       s2d = scalar2(b1(1,itk),vtemp1d(1))
8549 #ifdef MOMENT
8550       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8551       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8552 #endif
8553       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8554 #ifdef MOMENT
8555       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8556       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8557       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8558 #endif
8559 c      s1d=0.0d0
8560 c      s2d=0.0d0
8561 c      s8d=0.0d0
8562 c      s12d=0.0d0
8563 c      s13d=0.0d0
8564 #ifdef MOMENT
8565       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8566      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8567 #else
8568       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8569      &               -0.5d0*ekont*(s2d+s12d)
8570 #endif
8571 C Derivatives in gamma(i+4)
8572       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8573       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8574       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8575 #ifdef MOMENT
8576       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8577       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8578       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8579 #endif
8580 c      s1d=0.0d0
8581 c      s2d=0.0d0
8582 c      s8d=0.0d0
8583 C      s12d=0.0d0
8584 c      s13d=0.0d0
8585 #ifdef MOMENT
8586       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8587 #else
8588       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8589 #endif
8590 C Derivatives in gamma(i+5)
8591 #ifdef MOMENT
8592       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8593       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8594       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8595 #endif
8596       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8597       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8598       s2d = scalar2(b1(1,itk),vtemp1d(1))
8599 #ifdef MOMENT
8600       call transpose2(AEA(1,1,2),atempd(1,1))
8601       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8602       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8603 #endif
8604       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8605       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8606 #ifdef MOMENT
8607       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8608       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8609       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8610 #endif
8611 c      s1d=0.0d0
8612 c      s2d=0.0d0
8613 c      s8d=0.0d0
8614 c      s12d=0.0d0
8615 c      s13d=0.0d0
8616 #ifdef MOMENT
8617       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8618      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8619 #else
8620       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8621      &               -0.5d0*ekont*(s2d+s12d)
8622 #endif
8623 C Cartesian derivatives
8624       do iii=1,2
8625         do kkk=1,5
8626           do lll=1,3
8627 #ifdef MOMENT
8628             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8629             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8630             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8631 #endif
8632             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8633             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8634      &          vtemp1d(1))
8635             s2d = scalar2(b1(1,itk),vtemp1d(1))
8636 #ifdef MOMENT
8637             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8638             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8639             s8d = -(atempd(1,1)+atempd(2,2))*
8640      &           scalar2(cc(1,1,itl),vtemp2(1))
8641 #endif
8642             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8643      &           auxmatd(1,1))
8644             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8645             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8646 c      s1d=0.0d0
8647 c      s2d=0.0d0
8648 c      s8d=0.0d0
8649 c      s12d=0.0d0
8650 c      s13d=0.0d0
8651 #ifdef MOMENT
8652             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8653      &        - 0.5d0*(s1d+s2d)
8654 #else
8655             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8656      &        - 0.5d0*s2d
8657 #endif
8658 #ifdef MOMENT
8659             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8660      &        - 0.5d0*(s8d+s12d)
8661 #else
8662             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8663      &        - 0.5d0*s12d
8664 #endif
8665           enddo
8666         enddo
8667       enddo
8668 #ifdef MOMENT
8669       do kkk=1,5
8670         do lll=1,3
8671           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8672      &      achuj_tempd(1,1))
8673           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8674           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8675           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8676           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8677           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8678      &      vtemp4d(1))
8679           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8680           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8681           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8682         enddo
8683       enddo
8684 #endif
8685 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8686 cd     &  16*eel_turn6_num
8687 cd      goto 1112
8688       if (j.lt.nres-1) then
8689         j1=j+1
8690         j2=j-1
8691       else
8692         j1=j-1
8693         j2=j-2
8694       endif
8695       if (l.lt.nres-1) then
8696         l1=l+1
8697         l2=l-1
8698       else
8699         l1=l-1
8700         l2=l-2
8701       endif
8702       do ll=1,3
8703 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8704 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8705 cgrad        ghalf=0.5d0*ggg1(ll)
8706 cd        ghalf=0.0d0
8707         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8708         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8709         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8710      &    +ekont*derx_turn(ll,2,1)
8711         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8712         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8713      &    +ekont*derx_turn(ll,4,1)
8714         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8715         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8716         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8717 cgrad        ghalf=0.5d0*ggg2(ll)
8718 cd        ghalf=0.0d0
8719         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8720      &    +ekont*derx_turn(ll,2,2)
8721         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8722         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8723      &    +ekont*derx_turn(ll,4,2)
8724         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8725         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8726         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8727       enddo
8728 cd      goto 1112
8729 cgrad      do m=i+1,j-1
8730 cgrad        do ll=1,3
8731 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8732 cgrad        enddo
8733 cgrad      enddo
8734 cgrad      do m=k+1,l-1
8735 cgrad        do ll=1,3
8736 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8737 cgrad        enddo
8738 cgrad      enddo
8739 cgrad1112  continue
8740 cgrad      do m=i+2,j2
8741 cgrad        do ll=1,3
8742 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8743 cgrad        enddo
8744 cgrad      enddo
8745 cgrad      do m=k+2,l2
8746 cgrad        do ll=1,3
8747 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8748 cgrad        enddo
8749 cgrad      enddo
8750 cd      do iii=1,nres-3
8751 cd        write (2,*) iii,g_corr6_loc(iii)
8752 cd      enddo
8753       eello_turn6=ekont*eel_turn6
8754 cd      write (2,*) 'ekont',ekont
8755 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8756       return
8757       end
8758
8759 C-----------------------------------------------------------------------------
8760       double precision function scalar(u,v)
8761 !DIR$ INLINEALWAYS scalar
8762 #ifndef OSF
8763 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8764 #endif
8765       implicit none
8766       double precision u(3),v(3)
8767 cd      double precision sc
8768 cd      integer i
8769 cd      sc=0.0d0
8770 cd      do i=1,3
8771 cd        sc=sc+u(i)*v(i)
8772 cd      enddo
8773 cd      scalar=sc
8774
8775       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8776       return
8777       end
8778 crc-------------------------------------------------
8779       SUBROUTINE MATVEC2(A1,V1,V2)
8780 !DIR$ INLINEALWAYS MATVEC2
8781 #ifndef OSF
8782 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8783 #endif
8784       implicit real*8 (a-h,o-z)
8785       include 'DIMENSIONS'
8786       DIMENSION A1(2,2),V1(2),V2(2)
8787 c      DO 1 I=1,2
8788 c        VI=0.0
8789 c        DO 3 K=1,2
8790 c    3     VI=VI+A1(I,K)*V1(K)
8791 c        Vaux(I)=VI
8792 c    1 CONTINUE
8793
8794       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8795       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8796
8797       v2(1)=vaux1
8798       v2(2)=vaux2
8799       END
8800 C---------------------------------------
8801       SUBROUTINE MATMAT2(A1,A2,A3)
8802 #ifndef OSF
8803 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8804 #endif
8805       implicit real*8 (a-h,o-z)
8806       include 'DIMENSIONS'
8807       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8808 c      DIMENSION AI3(2,2)
8809 c        DO  J=1,2
8810 c          A3IJ=0.0
8811 c          DO K=1,2
8812 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8813 c          enddo
8814 c          A3(I,J)=A3IJ
8815 c       enddo
8816 c      enddo
8817
8818       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8819       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8820       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8821       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8822
8823       A3(1,1)=AI3_11
8824       A3(2,1)=AI3_21
8825       A3(1,2)=AI3_12
8826       A3(2,2)=AI3_22
8827       END
8828
8829 c-------------------------------------------------------------------------
8830       double precision function scalar2(u,v)
8831 !DIR$ INLINEALWAYS scalar2
8832       implicit none
8833       double precision u(2),v(2)
8834       double precision sc
8835       integer i
8836       scalar2=u(1)*v(1)+u(2)*v(2)
8837       return
8838       end
8839
8840 C-----------------------------------------------------------------------------
8841
8842       subroutine transpose2(a,at)
8843 !DIR$ INLINEALWAYS transpose2
8844 #ifndef OSF
8845 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8846 #endif
8847       implicit none
8848       double precision a(2,2),at(2,2)
8849       at(1,1)=a(1,1)
8850       at(1,2)=a(2,1)
8851       at(2,1)=a(1,2)
8852       at(2,2)=a(2,2)
8853       return
8854       end
8855 c--------------------------------------------------------------------------
8856       subroutine transpose(n,a,at)
8857       implicit none
8858       integer n,i,j
8859       double precision a(n,n),at(n,n)
8860       do i=1,n
8861         do j=1,n
8862           at(j,i)=a(i,j)
8863         enddo
8864       enddo
8865       return
8866       end
8867 C---------------------------------------------------------------------------
8868       subroutine prodmat3(a1,a2,kk,transp,prod)
8869 !DIR$ INLINEALWAYS prodmat3
8870 #ifndef OSF
8871 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8872 #endif
8873       implicit none
8874       integer i,j
8875       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8876       logical transp
8877 crc      double precision auxmat(2,2),prod_(2,2)
8878
8879       if (transp) then
8880 crc        call transpose2(kk(1,1),auxmat(1,1))
8881 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8882 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8883
8884            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8885      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8886            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8887      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8888            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8889      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8890            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8891      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8892
8893       else
8894 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8895 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8896
8897            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8898      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8899            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8900      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8901            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8902      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8903            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8904      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8905
8906       endif
8907 c      call transpose2(a2(1,1),a2t(1,1))
8908
8909 crc      print *,transp
8910 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8911 crc      print *,((prod(i,j),i=1,2),j=1,2)
8912
8913       return
8914       end
8915