source/unres/src_MD-M/energy_p_new_barrier.F

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 cmc
 125 cmc Sep-06: egb takes care of dynamic ss bonds too
 126 cmc
 127 c      if (dyn_ss) call dyn_set_nss
 128
 129 c      print *,"Processor",myrank," computed USCSC"
 130 #ifdef TIMING
 131       time01=MPI_Wtime()
 132 #endif
 133       call vec_and_deriv
 134 #ifdef TIMING
 135       time_vec=time_vec+MPI_Wtime()-time01
 136 #endif
 137 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 138       if (ipot.lt.6) then
 139 #ifdef SPLITELE
 140          if (welec.gt.0d0.or.wvdwpp.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 #else
 145          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 146      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 147      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 148      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 149 #endif
 150             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 151          else
 152             ees=0.0d0
 153             evdw1=0.0d0
 154             eel_loc=0.0d0
 155             eello_turn3=0.0d0
 156             eello_turn4=0.0d0
 157          endif
 158       else
 159 c        write (iout,*) "Soft-spheer ELEC potential"
 160         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 161      &   eello_turn4)
 162       endif
 163 c      print *,"Processor",myrank," computed UELEC"
 164 C
 165 C Calculate excluded-volume interaction energy between peptide groups
 166 C and side chains.
 167 C
 168       if (ipot.lt.6) then
 169        if(wscp.gt.0d0) then
 170         call escp(evdw2,evdw2_14)
 171        else
 172         evdw2=0
 173         evdw2_14=0
 174        endif
 175       else
 176 c        write (iout,*) "Soft-sphere SCP potential"
 177         call escp_soft_sphere(evdw2,evdw2_14)
 178       endif
 179 c
 180 c Calculate the bond-stretching energy
 181 c
 182       call ebond(estr)
 183 C
 184 C Calculate the disulfide-bridge and other energy and the contributions
 185 C from other distance constraints.
 186 cd    print *,'Calling EHPB'
 187       call edis(ehpb)
 188 cd    print *,'EHPB exitted succesfully.'
 189 C
 190 C Calculate the virtual-bond-angle energy.
 191 C
 192       if (wang.gt.0d0) then
 193         call ebend(ebe)
 194       else
 195         ebe=0
 196       endif
 197 c      print *,"Processor",myrank," computed UB"
 198 C
 199 C Calculate the SC local energy.
 200 C
 201       call esc(escloc)
 202 c      print *,"Processor",myrank," computed USC"
 203 C
 204 C Calculate the virtual-bond torsional energy.
 205 C
 206 cd    print *,'nterm=',nterm
 207       if (wtor.gt.0) then
 208        call etor(etors,edihcnstr)
 209       else
 210        etors=0
 211        edihcnstr=0
 212       endif
 213 c      print *,"Processor",myrank," computed Utor"
 214 C
 215 C 6/23/01 Calculate double-torsional energy
 216 C
 217       if (wtor_d.gt.0) then
 218        call etor_d(etors_d)
 219       else
 220        etors_d=0
 221       endif
 222 c      print *,"Processor",myrank," computed Utord"
 223 C
 224 C 21/5/07 Calculate local sicdechain correlation energy
 225 C
 226       if (wsccor.gt.0.0d0) then
 227         call eback_sc_corr(esccor)
 228       else
 229         esccor=0.0d0
 230       endif
 231 c      print *,"Processor",myrank," computed Usccorr"
 232 C
 233 C 12/1/95 Multi-body terms
 234 C
 235       n_corr=0
 236       n_corr1=0
 237       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 238      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 239          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 240 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 241 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 242       else
 243          ecorr=0.0d0
 244          ecorr5=0.0d0
 245          ecorr6=0.0d0
 246          eturn6=0.0d0
 247       endif
 248       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 250 cd         write (iout,*) "multibody_hb ecorr",ecorr
 251       endif
 252 c      print *,"Processor",myrank," computed Ucorr"
 253 C
 254 C If performing constraint dynamics, call the constraint energy
 255 C  after the equilibration time
 256       if(usampl.and.totT.gt.eq_time) then
 257          call EconstrQ
 258          call Econstr_back
 259       else
 260          Uconst=0.0d0
 261          Uconst_back=0.0d0
 262       endif
 263 #ifdef TIMING
 264       time_enecalc=time_enecalc+MPI_Wtime()-time00
 265 #endif
 266 c      print *,"Processor",myrank," computed Uconstr"
 267 #ifdef TIMING
 268       time00=MPI_Wtime()
 269 #endif
 270 c
 271 C Sum the energies
 272 C
 273       energia(1)=evdw
 274 #ifdef SCP14
 275       energia(2)=evdw2-evdw2_14
 276       energia(18)=evdw2_14
 277 #else
 278       energia(2)=evdw2
 279       energia(18)=0.0d0
 280 #endif
 281 #ifdef SPLITELE
 282       energia(3)=ees
 283       energia(16)=evdw1
 284 #else
 285       energia(3)=ees+evdw1
 286       energia(16)=0.0d0
 287 #endif
 288       energia(4)=ecorr
 289       energia(5)=ecorr5
 290       energia(6)=ecorr6
 291       energia(7)=eel_loc
 292       energia(8)=eello_turn3
 293       energia(9)=eello_turn4
 294       energia(10)=eturn6
 295       energia(11)=ebe
 296       energia(12)=escloc
 297       energia(13)=etors
 298       energia(14)=etors_d
 299       energia(15)=ehpb
 300       energia(19)=edihcnstr
 301       energia(17)=estr
 302       energia(20)=Uconst+Uconst_back
 303       energia(21)=esccor
 304 c      print *," Processor",myrank," calls SUM_ENERGY"
 305       call sum_energy(energia,.true.)
 306       if (dyn_ss) call dyn_set_nss
 307 c      print *," Processor",myrank," left SUM_ENERGY"
 308 #ifdef TIMING
 309       time_sumene=time_sumene+MPI_Wtime()-time00
 310 #endif
 311       return
 312       end
 313 c-------------------------------------------------------------------------------
 314       subroutine sum_energy(energia,reduce)
 315       implicit real*8 (a-h,o-z)
 316       include 'DIMENSIONS'
 317 #ifndef ISNAN
 318       external proc_proc
 319 #ifdef WINPGI
 320 cMS$ATTRIBUTES C ::  proc_proc
 321 #endif
 322 #endif
 323 #ifdef MPI
 324       include "mpif.h"
 325 #endif
 326       include 'COMMON.SETUP'
 327       include 'COMMON.IOUNITS'
 328       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 329       include 'COMMON.FFIELD'
 330       include 'COMMON.DERIV'
 331       include 'COMMON.INTERACT'
 332       include 'COMMON.SBRIDGE'
 333       include 'COMMON.CHAIN'
 334       include 'COMMON.VAR'
 335       include 'COMMON.CONTROL'
 336       include 'COMMON.TIME1'
 337       logical reduce
 338 #ifdef MPI
 339       if (nfgtasks.gt.1 .and. reduce) then
 340 #ifdef DEBUG
 341         write (iout,*) "energies before REDUCE"
 342         call enerprint(energia)
 343         call flush(iout)
 344 #endif
 345         do i=0,n_ene
 346           enebuff(i)=energia(i)
 347         enddo
 348         time00=MPI_Wtime()
 349         call MPI_Barrier(FG_COMM,IERR)
 350         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 351         time00=MPI_Wtime()
 352         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 353      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 354 #ifdef DEBUG
 355         write (iout,*) "energies after REDUCE"
 356         call enerprint(energia)
 357         call flush(iout)
 358 #endif
 359         time_Reduce=time_Reduce+MPI_Wtime()-time00
 360       endif
 361       if (fg_rank.eq.0) then
 362 #endif
 363       evdw=energia(1)
 364 #ifdef SCP14
 365       evdw2=energia(2)+energia(18)
 366       evdw2_14=energia(18)
 367 #else
 368       evdw2=energia(2)
 369 #endif
 370 #ifdef SPLITELE
 371       ees=energia(3)
 372       evdw1=energia(16)
 373 #else
 374       ees=energia(3)
 375       evdw1=0.0d0
 376 #endif
 377       ecorr=energia(4)
 378       ecorr5=energia(5)
 379       ecorr6=energia(6)
 380       eel_loc=energia(7)
 381       eello_turn3=energia(8)
 382       eello_turn4=energia(9)
 383       eturn6=energia(10)
 384       ebe=energia(11)
 385       escloc=energia(12)
 386       etors=energia(13)
 387       etors_d=energia(14)
 388       ehpb=energia(15)
 389       edihcnstr=energia(19)
 390       estr=energia(17)
 391       Uconst=energia(20)
 392       esccor=energia(21)
 393 #ifdef SPLITELE
 394       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 395      & +wang*ebe+wtor*etors+wscloc*escloc
 396      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 397      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 398      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 399      & +wbond*estr+Uconst+wsccor*esccor
 400 #else
 401       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 402      & +wang*ebe+wtor*etors+wscloc*escloc
 403      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 404      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 405      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 406      & +wbond*estr+Uconst+wsccor*esccor
 407 #endif
 408       energia(0)=etot
 409 c detecting NaNQ
 410 #ifdef ISNAN
 411 #ifdef AIX
 412       if (isnan(etot).ne.0) energia(0)=1.0d+99
 413 #else
 414       if (isnan(etot)) energia(0)=1.0d+99
 415 #endif
 416 #else
 417       i=0
 418 #ifdef WINPGI
 419       idumm=proc_proc(etot,i)
 420 #else
 421       call proc_proc(etot,i)
 422 #endif
 423       if(i.eq.1)energia(0)=1.0d+99
 424 #endif
 425 #ifdef MPI
 426       endif
 427 #endif
 428       return
 429       end
 430 c-------------------------------------------------------------------------------
 431       subroutine sum_gradient
 432       implicit real*8 (a-h,o-z)
 433       include 'DIMENSIONS'
 434 #ifndef ISNAN
 435       external proc_proc
 436 #ifdef WINPGI
 437 cMS$ATTRIBUTES C ::  proc_proc
 438 #endif
 439 #endif
 440 #ifdef MPI
 441       include 'mpif.h'
 442 #endif
 443       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 444      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 445 #endif
 446       include 'COMMON.SETUP'
 447       include 'COMMON.IOUNITS'
 448       include 'COMMON.FFIELD'
 449       include 'COMMON.DERIV'
 450       include 'COMMON.INTERACT'
 451       include 'COMMON.SBRIDGE'
 452       include 'COMMON.CHAIN'
 453       include 'COMMON.VAR'
 454       include 'COMMON.CONTROL'
 455       include 'COMMON.TIME1'
 456       include 'COMMON.MAXGRAD'
 457       include 'COMMON.SCCOR'
 458 #ifdef TIMING
 459       time01=MPI_Wtime()
 460 #endif
 461 #ifdef DEBUG
 462       write (iout,*) "sum_gradient gvdwc, gvdwx"
 463       do i=1,nres
 464         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 465      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 466       enddo
 467       call flush(iout)
 468 #endif
 469 #ifdef MPI
 470 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 471         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 472      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 473 #endif
 474 C
 475 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 476 C            in virtual-bond-vector coordinates
 477 C
 478 #ifdef DEBUG
 479 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 480 c      do i=1,nres-1
 481 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 482 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 483 c      enddo
 484 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 485 c      do i=1,nres-1
 486 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 487 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 488 c      enddo
 489       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 490       do i=1,nres
 491         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 492      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 493      &   g_corr5_loc(i)
 494       enddo
 495       call flush(iout)
 496 #endif
 497 #ifdef SPLITELE
 498       do i=1,nct
 499         do j=1,3
 500           gradbufc(j,i)=wsc*gvdwc(j,i)+
 501      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 502      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 503      &                wel_loc*gel_loc_long(j,i)+
 504      &                wcorr*gradcorr_long(j,i)+
 505      &                wcorr5*gradcorr5_long(j,i)+
 506      &                wcorr6*gradcorr6_long(j,i)+
 507      &                wturn6*gcorr6_turn_long(j,i)+
 508      &                wstrain*ghpbc(j,i)
 509         enddo
 510       enddo
 511 #else
 512       do i=1,nct
 513         do j=1,3
 514           gradbufc(j,i)=wsc*gvdwc(j,i)+
 515      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 516      &                welec*gelc_long(j,i)+
 517      &                wbond*gradb(j,i)+
 518      &                wel_loc*gel_loc_long(j,i)+
 519      &                wcorr*gradcorr_long(j,i)+
 520      &                wcorr5*gradcorr5_long(j,i)+
 521      &                wcorr6*gradcorr6_long(j,i)+
 522      &                wturn6*gcorr6_turn_long(j,i)+
 523      &                wstrain*ghpbc(j,i)
 524         enddo
 525       enddo
 526 #endif
 527 #ifdef MPI
 528       if (nfgtasks.gt.1) then
 529       time00=MPI_Wtime()
 530 #ifdef DEBUG
 531       write (iout,*) "gradbufc before allreduce"
 532       do i=1,nres
 533         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 534       enddo
 535       call flush(iout)
 536 #endif
 537       do i=1,nres
 538         do j=1,3
 539           gradbufc_sum(j,i)=gradbufc(j,i)
 540         enddo
 541       enddo
 542 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 543 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 544 c      time_reduce=time_reduce+MPI_Wtime()-time00
 545 #ifdef DEBUG
 546 c      write (iout,*) "gradbufc_sum after allreduce"
 547 c      do i=1,nres
 548 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 549 c      enddo
 550 c      call flush(iout)
 551 #endif
 552 #ifdef TIMING
 553 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 554 #endif
 555       do i=nnt,nres
 556         do k=1,3
 557           gradbufc(k,i)=0.0d0
 558         enddo
 559       enddo
 560 #ifdef DEBUG
 561       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 562       write (iout,*) (i," jgrad_start",jgrad_start(i),
 563      &                  " jgrad_end  ",jgrad_end(i),
 564      &                  i=igrad_start,igrad_end)
 565 #endif
 566 c
 567 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 568 c do not parallelize this part.
 569 c
 570 c      do i=igrad_start,igrad_end
 571 c        do j=jgrad_start(i),jgrad_end(i)
 572 c          do k=1,3
 573 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 574 c          enddo
 575 c        enddo
 576 c      enddo
 577       do j=1,3
 578         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 579       enddo
 580       do i=nres-2,nnt,-1
 581         do j=1,3
 582           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 583         enddo
 584       enddo
 585 #ifdef DEBUG
 586       write (iout,*) "gradbufc after summing"
 587       do i=1,nres
 588         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 589       enddo
 590       call flush(iout)
 591 #endif
 592       else
 593 #endif
 594 #ifdef DEBUG
 595       write (iout,*) "gradbufc"
 596       do i=1,nres
 597         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 598       enddo
 599       call flush(iout)
 600 #endif
 601       do i=1,nres
 602         do j=1,3
 603           gradbufc_sum(j,i)=gradbufc(j,i)
 604           gradbufc(j,i)=0.0d0
 605         enddo
 606       enddo
 607       do j=1,3
 608         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 609       enddo
 610       do i=nres-2,nnt,-1
 611         do j=1,3
 612           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 613         enddo
 614       enddo
 615 c      do i=nnt,nres-1
 616 c        do k=1,3
 617 c          gradbufc(k,i)=0.0d0
 618 c        enddo
 619 c        do j=i+1,nres
 620 c          do k=1,3
 621 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 622 c          enddo
 623 c        enddo
 624 c      enddo
 625 #ifdef DEBUG
 626       write (iout,*) "gradbufc after summing"
 627       do i=1,nres
 628         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 629       enddo
 630       call flush(iout)
 631 #endif
 632 #ifdef MPI
 633       endif
 634 #endif
 635       do k=1,3
 636         gradbufc(k,nres)=0.0d0
 637       enddo
 638       do i=1,nct
 639         do j=1,3
 640 #ifdef SPLITELE
 641           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 642      &                wel_loc*gel_loc(j,i)+
 643      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 644      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 645      &                wel_loc*gel_loc_long(j,i)+
 646      &                wcorr*gradcorr_long(j,i)+
 647      &                wcorr5*gradcorr5_long(j,i)+
 648      &                wcorr6*gradcorr6_long(j,i)+
 649      &                wturn6*gcorr6_turn_long(j,i))+
 650      &                wbond*gradb(j,i)+
 651      &                wcorr*gradcorr(j,i)+
 652      &                wturn3*gcorr3_turn(j,i)+
 653      &                wturn4*gcorr4_turn(j,i)+
 654      &                wcorr5*gradcorr5(j,i)+
 655      &                wcorr6*gradcorr6(j,i)+
 656      &                wturn6*gcorr6_turn(j,i)+
 657      &                wsccor*gsccorc(j,i)
 658      &               +wscloc*gscloc(j,i)
 659 #else
 660           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 661      &                wel_loc*gel_loc(j,i)+
 662      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 663      &                welec*gelc_long(j,i)
 664      &                wel_loc*gel_loc_long(j,i)+
 665      &                wcorr*gcorr_long(j,i)+
 666      &                wcorr5*gradcorr5_long(j,i)+
 667      &                wcorr6*gradcorr6_long(j,i)+
 668      &                wturn6*gcorr6_turn_long(j,i))+
 669      &                wbond*gradb(j,i)+
 670      &                wcorr*gradcorr(j,i)+
 671      &                wturn3*gcorr3_turn(j,i)+
 672      &                wturn4*gcorr4_turn(j,i)+
 673      &                wcorr5*gradcorr5(j,i)+
 674      &                wcorr6*gradcorr6(j,i)+
 675      &                wturn6*gcorr6_turn(j,i)+
 676      &                wsccor*gsccorc(j,i)
 677      &               +wscloc*gscloc(j,i)
 678 #endif
 679           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 680      &                  wbond*gradbx(j,i)+
 681      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 682      &                  wsccor*gsccorx(j,i)
 683      &                 +wscloc*gsclocx(j,i)
 684         enddo
 685       enddo
 686 #ifdef DEBUG
 687       write (iout,*) "gloc before adding corr"
 688       do i=1,4*nres
 689         write (iout,*) i,gloc(i,icg)
 690       enddo
 691 #endif
 692       do i=1,nres-3
 693         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 694      &   +wcorr5*g_corr5_loc(i)
 695      &   +wcorr6*g_corr6_loc(i)
 696      &   +wturn4*gel_loc_turn4(i)
 697      &   +wturn3*gel_loc_turn3(i)
 698      &   +wturn6*gel_loc_turn6(i)
 699      &   +wel_loc*gel_loc_loc(i)
 700       enddo
 701 #ifdef DEBUG
 702       write (iout,*) "gloc after adding corr"
 703       do i=1,4*nres
 704         write (iout,*) i,gloc(i,icg)
 705       enddo
 706 #endif
 707 #ifdef MPI
 708       if (nfgtasks.gt.1) then
 709         do j=1,3
 710           do i=1,nres
 711             gradbufc(j,i)=gradc(j,i,icg)
 712             gradbufx(j,i)=gradx(j,i,icg)
 713           enddo
 714         enddo
 715         do i=1,4*nres
 716           glocbuf(i)=gloc(i,icg)
 717         enddo
 718 #define DEBUG
 719 #ifdef DEBUG
 720       write (iout,*) "gloc_sc before reduce"
 721       do i=1,nres
 722        do j=1,1
 723         write (iout,*) i,j,gloc_sc(j,i,icg)
 724        enddo
 725       enddo
 726 #endif
 727 #undef DEBUG
 728         do i=1,nres
 729          do j=1,3
 730           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 731          enddo
 732         enddo
 733         time00=MPI_Wtime()
 734         call MPI_Barrier(FG_COMM,IERR)
 735         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 736         time00=MPI_Wtime()
 737         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 738      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 739         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 742      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 743         time_reduce=time_reduce+MPI_Wtime()-time00
 744         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 745      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 746         time_reduce=time_reduce+MPI_Wtime()-time00
 747 #define DEBUG
 748 #ifdef DEBUG
 749       write (iout,*) "gloc_sc after reduce"
 750       do i=1,nres
 751        do j=1,1
 752         write (iout,*) i,j,gloc_sc(j,i,icg)
 753        enddo
 754       enddo
 755 #endif
 756 #undef DEBUG
 757 #ifdef DEBUG
 758       write (iout,*) "gloc after reduce"
 759       do i=1,4*nres
 760         write (iout,*) i,gloc(i,icg)
 761       enddo
 762 #endif
 763       endif
 764 #endif
 765       if (gnorm_check) then
 766 c
 767 c Compute the maximum elements of the gradient
 768 c
 769       gvdwc_max=0.0d0
 770       gvdwc_scp_max=0.0d0
 771       gelc_max=0.0d0
 772       gvdwpp_max=0.0d0
 773       gradb_max=0.0d0
 774       ghpbc_max=0.0d0
 775       gradcorr_max=0.0d0
 776       gel_loc_max=0.0d0
 777       gcorr3_turn_max=0.0d0
 778       gcorr4_turn_max=0.0d0
 779       gradcorr5_max=0.0d0
 780       gradcorr6_max=0.0d0
 781       gcorr6_turn_max=0.0d0
 782       gsccorc_max=0.0d0
 783       gscloc_max=0.0d0
 784       gvdwx_max=0.0d0
 785       gradx_scp_max=0.0d0
 786       ghpbx_max=0.0d0
 787       gradxorr_max=0.0d0
 788       gsccorx_max=0.0d0
 789       gsclocx_max=0.0d0
 790       do i=1,nct
 791         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 792         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 793         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 794         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 795      &   gvdwc_scp_max=gvdwc_scp_norm
 796         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 797         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 798         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 799         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 800         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 801         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 802         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 803         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 804         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 805         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 806         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 807         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 808         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 809      &    gcorr3_turn(1,i)))
 810         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 811      &    gcorr3_turn_max=gcorr3_turn_norm
 812         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 813      &    gcorr4_turn(1,i)))
 814         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 815      &    gcorr4_turn_max=gcorr4_turn_norm
 816         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 817         if (gradcorr5_norm.gt.gradcorr5_max)
 818      &    gradcorr5_max=gradcorr5_norm
 819         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 820         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 821         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 822      &    gcorr6_turn(1,i)))
 823         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 824      &    gcorr6_turn_max=gcorr6_turn_norm
 825         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 826         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 827         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 828         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 829         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 830         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 831         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 832         if (gradx_scp_norm.gt.gradx_scp_max)
 833      &    gradx_scp_max=gradx_scp_norm
 834         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 835         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 836         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 837         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 838         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 839         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 840         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 841         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 842       enddo
 843       if (gradout) then
 844 #ifdef AIX
 845         open(istat,file=statname,position="append")
 846 #else
 847         open(istat,file=statname,access="append")
 848 #endif
 849         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 850      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 851      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 852      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 853      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 854      &     gsccorx_max,gsclocx_max
 855         close(istat)
 856         if (gvdwc_max.gt.1.0d4) then
 857           write (iout,*) "gvdwc gvdwx gradb gradbx"
 858           do i=nnt,nct
 859             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 860      &        gradb(j,i),gradbx(j,i),j=1,3)
 861           enddo
 862           call pdbout(0.0d0,'cipiszcze',iout)
 863           call flush(iout)
 864         endif
 865       endif
 866       endif
 867 #ifdef DEBUG
 868       write (iout,*) "gradc gradx gloc"
 869       do i=1,nres
 870         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 871      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 872       enddo
 873 #endif
 874 #ifdef TIMING
 875       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 876 #endif
 877       return
 878       end
 879 c-------------------------------------------------------------------------------
 880       subroutine rescale_weights(t_bath)
 881       implicit real*8 (a-h,o-z)
 882       include 'DIMENSIONS'
 883       include 'COMMON.IOUNITS'
 884       include 'COMMON.FFIELD'
 885       include 'COMMON.SBRIDGE'
 886       double precision kfac /2.4d0/
 887       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 888 c      facT=temp0/t_bath
 889 c      facT=2*temp0/(t_bath+temp0)
 890       if (rescale_mode.eq.0) then
 891         facT=1.0d0
 892         facT2=1.0d0
 893         facT3=1.0d0
 894         facT4=1.0d0
 895         facT5=1.0d0
 896       else if (rescale_mode.eq.1) then
 897         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 898         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 899         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 900         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 901         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 902       else if (rescale_mode.eq.2) then
 903         x=t_bath/temp0
 904         x2=x*x
 905         x3=x2*x
 906         x4=x3*x
 907         x5=x4*x
 908         facT=licznik/dlog(dexp(x)+dexp(-x))
 909         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 910         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 911         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 912         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 913       else
 914         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 915         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 916 #ifdef MPI
 917        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 918 #endif
 919        stop 555
 920       endif
 921       welec=weights(3)*fact
 922       wcorr=weights(4)*fact3
 923       wcorr5=weights(5)*fact4
 924       wcorr6=weights(6)*fact5
 925       wel_loc=weights(7)*fact2
 926       wturn3=weights(8)*fact2
 927       wturn4=weights(9)*fact3
 928       wturn6=weights(10)*fact5
 929       wtor=weights(13)*fact
 930       wtor_d=weights(14)*fact2
 931       wsccor=weights(21)*fact
 932
 933       return
 934       end
 935 C------------------------------------------------------------------------
 936       subroutine enerprint(energia)
 937       implicit real*8 (a-h,o-z)
 938       include 'DIMENSIONS'
 939       include 'COMMON.IOUNITS'
 940       include 'COMMON.FFIELD'
 941       include 'COMMON.SBRIDGE'
 942       include 'COMMON.MD'
 943       double precision energia(0:n_ene)
 944       etot=energia(0)
 945       evdw=energia(1)
 946       evdw2=energia(2)
 947 #ifdef SCP14
 948       evdw2=energia(2)+energia(18)
 949 #else
 950       evdw2=energia(2)
 951 #endif
 952       ees=energia(3)
 953 #ifdef SPLITELE
 954       evdw1=energia(16)
 955 #endif
 956       ecorr=energia(4)
 957       ecorr5=energia(5)
 958       ecorr6=energia(6)
 959       eel_loc=energia(7)
 960       eello_turn3=energia(8)
 961       eello_turn4=energia(9)
 962       eello_turn6=energia(10)
 963       ebe=energia(11)
 964       escloc=energia(12)
 965       etors=energia(13)
 966       etors_d=energia(14)
 967       ehpb=energia(15)
 968       edihcnstr=energia(19)
 969       estr=energia(17)
 970       Uconst=energia(20)
 971       esccor=energia(21)
 972 #ifdef SPLITELE
 973       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 974      &  estr,wbond,ebe,wang,
 975      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 976      &  ecorr,wcorr,
 977      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 978      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 979      &  edihcnstr,ebr*nss,
 980      &  Uconst,etot
 981    10 format (/'Virtual-chain energies:'//
 982      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 983      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 984      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 985      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 986      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 987      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 988      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 989      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 990      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 991      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 992      & ' (SS bridges & dist. cnstr.)'/
 993      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 994      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 995      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 996      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 997      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 998      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 999      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1000      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1001      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1002      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1003      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1004      & 'ETOT=  ',1pE16.6,' (total)')
1005 #else
1006       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1007      &  estr,wbond,ebe,wang,
1008      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1009      &  ecorr,wcorr,
1010      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1011      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1012      &  ebr*nss,Uconst,etot
1013    10 format (/'Virtual-chain energies:'//
1014      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1015      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1016      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1017      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1018      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1019      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1020      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1021      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1022      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1023      & ' (SS bridges & dist. cnstr.)'/
1024      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1025      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1026      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1027      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1028      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1029      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1030      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1031      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1032      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1033      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1034      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1035      & 'ETOT=  ',1pE16.6,' (total)')
1036 #endif
1037       return
1038       end
1039 C-----------------------------------------------------------------------
1040       subroutine elj(evdw)
1041 C
1042 C This subroutine calculates the interaction energy of nonbonded side chains
1043 C assuming the LJ potential of interaction.
1044 C
1045       implicit real*8 (a-h,o-z)
1046       include 'DIMENSIONS'
1047       parameter (accur=1.0d-10)
1048       include 'COMMON.GEO'
1049       include 'COMMON.VAR'
1050       include 'COMMON.LOCAL'
1051       include 'COMMON.CHAIN'
1052       include 'COMMON.DERIV'
1053       include 'COMMON.INTERACT'
1054       include 'COMMON.TORSION'
1055       include 'COMMON.SBRIDGE'
1056       include 'COMMON.NAMES'
1057       include 'COMMON.IOUNITS'
1058       include 'COMMON.CONTACTS'
1059       dimension gg(3)
1060 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1061       evdw=0.0D0
1062       do i=iatsc_s,iatsc_e
1063         itypi=itype(i)
1064         if (itypi.eq.21) cycle
1065         itypi1=itype(i+1)
1066         xi=c(1,nres+i)
1067         yi=c(2,nres+i)
1068         zi=c(3,nres+i)
1069 C Change 12/1/95
1070         num_conti=0
1071 C
1072 C Calculate SC interaction energy.
1073 C
1074         do iint=1,nint_gr(i)
1075 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1076 cd   &                  'iend=',iend(i,iint)
1077           do j=istart(i,iint),iend(i,iint)
1078             itypj=itype(j)
1079             if (itypj.eq.21) cycle
1080             xj=c(1,nres+j)-xi
1081             yj=c(2,nres+j)-yi
1082             zj=c(3,nres+j)-zi
1083 C Change 12/1/95 to calculate four-body interactions
1084             rij=xj*xj+yj*yj+zj*zj
1085             rrij=1.0D0/rij
1086 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1087             eps0ij=eps(itypi,itypj)
1088             fac=rrij**expon2
1089             e1=fac*fac*aa(itypi,itypj)
1090             e2=fac*bb(itypi,itypj)
1091             evdwij=e1+e2
1092 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1093 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1094 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1095 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1096 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1097 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1098             evdw=evdw+evdwij
1099 C
1100 C Calculate the components of the gradient in DC and X
1101 C
1102             fac=-rrij*(e1+evdwij)
1103             gg(1)=xj*fac
1104             gg(2)=yj*fac
1105             gg(3)=zj*fac
1106             do k=1,3
1107               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1108               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1109               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1110               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1111             enddo
1112 cgrad            do k=i,j-1
1113 cgrad              do l=1,3
1114 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1115 cgrad              enddo
1116 cgrad            enddo
1117 C
1118 C 12/1/95, revised on 5/20/97
1119 C
1120 C Calculate the contact function. The ith column of the array JCONT will
1121 C contain the numbers of atoms that make contacts with the atom I (of numbers
1122 C greater than I). The arrays FACONT and GACONT will contain the values of
1123 C the contact function and its derivative.
1124 C
1125 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1126 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1127 C Uncomment next line, if the correlation interactions are contact function only
1128             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1129               rij=dsqrt(rij)
1130               sigij=sigma(itypi,itypj)
1131               r0ij=rs0(itypi,itypj)
1132 C
1133 C Check whether the SC's are not too far to make a contact.
1134 C
1135               rcut=1.5d0*r0ij
1136               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1137 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1138 C
1139               if (fcont.gt.0.0D0) then
1140 C If the SC-SC distance if close to sigma, apply spline.
1141 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1142 cAdam &             fcont1,fprimcont1)
1143 cAdam           fcont1=1.0d0-fcont1
1144 cAdam           if (fcont1.gt.0.0d0) then
1145 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1146 cAdam             fcont=fcont*fcont1
1147 cAdam           endif
1148 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1149 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1150 cga             do k=1,3
1151 cga               gg(k)=gg(k)*eps0ij
1152 cga             enddo
1153 cga             eps0ij=-evdwij*eps0ij
1154 C Uncomment for AL's type of SC correlation interactions.
1155 cadam           eps0ij=-evdwij
1156                 num_conti=num_conti+1
1157                 jcont(num_conti,i)=j
1158                 facont(num_conti,i)=fcont*eps0ij
1159                 fprimcont=eps0ij*fprimcont/rij
1160                 fcont=expon*fcont
1161 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1162 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1163 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1164 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1165                 gacont(1,num_conti,i)=-fprimcont*xj
1166                 gacont(2,num_conti,i)=-fprimcont*yj
1167                 gacont(3,num_conti,i)=-fprimcont*zj
1168 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1169 cd              write (iout,'(2i3,3f10.5)')
1170 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1171               endif
1172             endif
1173           enddo      ! j
1174         enddo        ! iint
1175 C Change 12/1/95
1176         num_cont(i)=num_conti
1177       enddo          ! i
1178       do i=1,nct
1179         do j=1,3
1180           gvdwc(j,i)=expon*gvdwc(j,i)
1181           gvdwx(j,i)=expon*gvdwx(j,i)
1182         enddo
1183       enddo
1184 C******************************************************************************
1185 C
1186 C                              N O T E !!!
1187 C
1188 C To save time, the factor of EXPON has been extracted from ALL components
1189 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1190 C use!
1191 C
1192 C******************************************************************************
1193       return
1194       end
1195 C-----------------------------------------------------------------------------
1196       subroutine eljk(evdw)
1197 C
1198 C This subroutine calculates the interaction energy of nonbonded side chains
1199 C assuming the LJK potential of interaction.
1200 C
1201       implicit real*8 (a-h,o-z)
1202       include 'DIMENSIONS'
1203       include 'COMMON.GEO'
1204       include 'COMMON.VAR'
1205       include 'COMMON.LOCAL'
1206       include 'COMMON.CHAIN'
1207       include 'COMMON.DERIV'
1208       include 'COMMON.INTERACT'
1209       include 'COMMON.IOUNITS'
1210       include 'COMMON.NAMES'
1211       dimension gg(3)
1212       logical scheck
1213 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1214       evdw=0.0D0
1215       do i=iatsc_s,iatsc_e
1216         itypi=itype(i)
1217         if (itypi.eq.21) cycle
1218         itypi1=itype(i+1)
1219         xi=c(1,nres+i)
1220         yi=c(2,nres+i)
1221         zi=c(3,nres+i)
1222 C
1223 C Calculate SC interaction energy.
1224 C
1225         do iint=1,nint_gr(i)
1226           do j=istart(i,iint),iend(i,iint)
1227             itypj=itype(j)
1228             if (itypj.eq.21) cycle
1229             xj=c(1,nres+j)-xi
1230             yj=c(2,nres+j)-yi
1231             zj=c(3,nres+j)-zi
1232             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1233             fac_augm=rrij**expon
1234             e_augm=augm(itypi,itypj)*fac_augm
1235             r_inv_ij=dsqrt(rrij)
1236             rij=1.0D0/r_inv_ij
1237             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1238             fac=r_shift_inv**expon
1239             e1=fac*fac*aa(itypi,itypj)
1240             e2=fac*bb(itypi,itypj)
1241             evdwij=e_augm+e1+e2
1242 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1243 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1244 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1245 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1246 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1247 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1248 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1249             evdw=evdw+evdwij
1250 C
1251 C Calculate the components of the gradient in DC and X
1252 C
1253             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1254             gg(1)=xj*fac
1255             gg(2)=yj*fac
1256             gg(3)=zj*fac
1257             do k=1,3
1258               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1259               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1260               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1261               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1262             enddo
1263 cgrad            do k=i,j-1
1264 cgrad              do l=1,3
1265 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1266 cgrad              enddo
1267 cgrad            enddo
1268           enddo      ! j
1269         enddo        ! iint
1270       enddo          ! i
1271       do i=1,nct
1272         do j=1,3
1273           gvdwc(j,i)=expon*gvdwc(j,i)
1274           gvdwx(j,i)=expon*gvdwx(j,i)
1275         enddo
1276       enddo
1277       return
1278       end
1279 C-----------------------------------------------------------------------------
1280       subroutine ebp(evdw)
1281 C
1282 C This subroutine calculates the interaction energy of nonbonded side chains
1283 C assuming the Berne-Pechukas potential of interaction.
1284 C
1285       implicit real*8 (a-h,o-z)
1286       include 'DIMENSIONS'
1287       include 'COMMON.GEO'
1288       include 'COMMON.VAR'
1289       include 'COMMON.LOCAL'
1290       include 'COMMON.CHAIN'
1291       include 'COMMON.DERIV'
1292       include 'COMMON.NAMES'
1293       include 'COMMON.INTERACT'
1294       include 'COMMON.IOUNITS'
1295       include 'COMMON.CALC'
1296       common /srutu/ icall
1297 c     double precision rrsave(maxdim)
1298       logical lprn
1299       evdw=0.0D0
1300 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1301       evdw=0.0D0
1302 c     if (icall.eq.0) then
1303 c       lprn=.true.
1304 c     else
1305         lprn=.false.
1306 c     endif
1307       ind=0
1308       do i=iatsc_s,iatsc_e
1309         itypi=itype(i)
1310         if (itypi.eq.21) cycle
1311         itypi1=itype(i+1)
1312         xi=c(1,nres+i)
1313         yi=c(2,nres+i)
1314         zi=c(3,nres+i)
1315         dxi=dc_norm(1,nres+i)
1316         dyi=dc_norm(2,nres+i)
1317         dzi=dc_norm(3,nres+i)
1318 c        dsci_inv=dsc_inv(itypi)
1319         dsci_inv=vbld_inv(i+nres)
1320 C
1321 C Calculate SC interaction energy.
1322 C
1323         do iint=1,nint_gr(i)
1324           do j=istart(i,iint),iend(i,iint)
1325             ind=ind+1
1326             itypj=itype(j)
1327             if (itypj.eq.21) cycle
1328 c            dscj_inv=dsc_inv(itypj)
1329             dscj_inv=vbld_inv(j+nres)
1330             chi1=chi(itypi,itypj)
1331             chi2=chi(itypj,itypi)
1332             chi12=chi1*chi2
1333             chip1=chip(itypi)
1334             chip2=chip(itypj)
1335             chip12=chip1*chip2
1336             alf1=alp(itypi)
1337             alf2=alp(itypj)
1338             alf12=0.5D0*(alf1+alf2)
1339 C For diagnostics only!!!
1340 c           chi1=0.0D0
1341 c           chi2=0.0D0
1342 c           chi12=0.0D0
1343 c           chip1=0.0D0
1344 c           chip2=0.0D0
1345 c           chip12=0.0D0
1346 c           alf1=0.0D0
1347 c           alf2=0.0D0
1348 c           alf12=0.0D0
1349             xj=c(1,nres+j)-xi
1350             yj=c(2,nres+j)-yi
1351             zj=c(3,nres+j)-zi
1352             dxj=dc_norm(1,nres+j)
1353             dyj=dc_norm(2,nres+j)
1354             dzj=dc_norm(3,nres+j)
1355             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1356 cd          if (icall.eq.0) then
1357 cd            rrsave(ind)=rrij
1358 cd          else
1359 cd            rrij=rrsave(ind)
1360 cd          endif
1361             rij=dsqrt(rrij)
1362 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1363             call sc_angular
1364 C Calculate whole angle-dependent part of epsilon and contributions
1365 C to its derivatives
1366             fac=(rrij*sigsq)**expon2
1367             e1=fac*fac*aa(itypi,itypj)
1368             e2=fac*bb(itypi,itypj)
1369             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1370             eps2der=evdwij*eps3rt
1371             eps3der=evdwij*eps2rt
1372             evdwij=evdwij*eps2rt*eps3rt
1373             evdw=evdw+evdwij
1374             if (lprn) then
1375             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1376             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1377 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1378 cd     &        restyp(itypi),i,restyp(itypj),j,
1379 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1380 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1381 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1382 cd     &        evdwij
1383             endif
1384 C Calculate gradient components.
1385             e1=e1*eps1*eps2rt**2*eps3rt**2
1386             fac=-expon*(e1+evdwij)
1387             sigder=fac/sigsq
1388             fac=rrij*fac
1389 C Calculate radial part of the gradient
1390             gg(1)=xj*fac
1391             gg(2)=yj*fac
1392             gg(3)=zj*fac
1393 C Calculate the angular part of the gradient and sum add the contributions
1394 C to the appropriate components of the Cartesian gradient.
1395             call sc_grad
1396           enddo      ! j
1397         enddo        ! iint
1398       enddo          ! i
1399 c     stop
1400       return
1401       end
1402 C-----------------------------------------------------------------------------
1403       subroutine egb(evdw)
1404 C
1405 C This subroutine calculates the interaction energy of nonbonded side chains
1406 C assuming the Gay-Berne potential of interaction.
1407 C
1408       implicit real*8 (a-h,o-z)
1409       include 'DIMENSIONS'
1410       include 'COMMON.GEO'
1411       include 'COMMON.VAR'
1412       include 'COMMON.LOCAL'
1413       include 'COMMON.CHAIN'
1414       include 'COMMON.DERIV'
1415       include 'COMMON.NAMES'
1416       include 'COMMON.INTERACT'
1417       include 'COMMON.IOUNITS'
1418       include 'COMMON.CALC'
1419       include 'COMMON.CONTROL'
1420       include 'COMMON.SBRIDGE'
1421       logical lprn
1422       evdw=0.0D0
1423 ccccc      energy_dec=.false.
1424 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1425       evdw=0.0D0
1426       lprn=.false.
1427 c     if (icall.eq.0) lprn=.false.
1428       ind=0
1429       do i=iatsc_s,iatsc_e
1430         itypi=itype(i)
1431         if (itypi.eq.21) cycle
1432         itypi1=itype(i+1)
1433         xi=c(1,nres+i)
1434         yi=c(2,nres+i)
1435         zi=c(3,nres+i)
1436         dxi=dc_norm(1,nres+i)
1437         dyi=dc_norm(2,nres+i)
1438         dzi=dc_norm(3,nres+i)
1439 c        dsci_inv=dsc_inv(itypi)
1440         dsci_inv=vbld_inv(i+nres)
1441 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1442 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1443 C
1444 C Calculate SC interaction energy.
1445 C
1446         do iint=1,nint_gr(i)
1447           do j=istart(i,iint),iend(i,iint)
1448             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1449               call dyn_ssbond_ene(i,j,evdwij)
1450               evdw=evdw+evdwij
1451               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1452      &                        'evdw',i,j,evdwij,' ss'
1453             ELSE
1454             ind=ind+1
1455             itypj=itype(j)
1456             if (itypj.eq.21) cycle
1457 c            dscj_inv=dsc_inv(itypj)
1458             dscj_inv=vbld_inv(j+nres)
1459 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1460 c     &       1.0d0/vbld(j+nres)
1461 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1462             sig0ij=sigma(itypi,itypj)
1463             chi1=chi(itypi,itypj)
1464             chi2=chi(itypj,itypi)
1465             chi12=chi1*chi2
1466             chip1=chip(itypi)
1467             chip2=chip(itypj)
1468             chip12=chip1*chip2
1469             alf1=alp(itypi)
1470             alf2=alp(itypj)
1471             alf12=0.5D0*(alf1+alf2)
1472 C For diagnostics only!!!
1473 c           chi1=0.0D0
1474 c           chi2=0.0D0
1475 c           chi12=0.0D0
1476 c           chip1=0.0D0
1477 c           chip2=0.0D0
1478 c           chip12=0.0D0
1479 c           alf1=0.0D0
1480 c           alf2=0.0D0
1481 c           alf12=0.0D0
1482             xj=c(1,nres+j)-xi
1483             yj=c(2,nres+j)-yi
1484             zj=c(3,nres+j)-zi
1485             dxj=dc_norm(1,nres+j)
1486             dyj=dc_norm(2,nres+j)
1487             dzj=dc_norm(3,nres+j)
1488 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1489 c            write (iout,*) "j",j," dc_norm",
1490 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1491             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1492             rij=dsqrt(rrij)
1493 C Calculate angle-dependent terms of energy and contributions to their
1494 C derivatives.
1495             call sc_angular
1496             sigsq=1.0D0/sigsq
1497             sig=sig0ij*dsqrt(sigsq)
1498             rij_shift=1.0D0/rij-sig+sig0ij
1499 c for diagnostics; uncomment
1500 c            rij_shift=1.2*sig0ij
1501 C I hate to put IF's in the loops, but here don't have another choice!!!!
1502             if (rij_shift.le.0.0D0) then
1503               evdw=1.0D20
1504 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1505 cd     &        restyp(itypi),i,restyp(itypj),j,
1506 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1507               return
1508             endif
1509             sigder=-sig*sigsq
1510 c---------------------------------------------------------------
1511             rij_shift=1.0D0/rij_shift
1512             fac=rij_shift**expon
1513             e1=fac*fac*aa(itypi,itypj)
1514             e2=fac*bb(itypi,itypj)
1515             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1516             eps2der=evdwij*eps3rt
1517             eps3der=evdwij*eps2rt
1518 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1519 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1520             evdwij=evdwij*eps2rt*eps3rt
1521             evdw=evdw+evdwij
1522             if (lprn) then
1523             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1524             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1525             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1526      &        restyp(itypi),i,restyp(itypj),j,
1527      &        epsi,sigm,chi1,chi2,chip1,chip2,
1528      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1529      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1530      &        evdwij
1531             endif
1532
1533             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1534      &                        'evdw',i,j,evdwij
1535
1536 C Calculate gradient components.
1537             e1=e1*eps1*eps2rt**2*eps3rt**2
1538             fac=-expon*(e1+evdwij)*rij_shift
1539             sigder=fac*sigder
1540             fac=rij*fac
1541 c            fac=0.0d0
1542 C Calculate the radial part of the gradient
1543             gg(1)=xj*fac
1544             gg(2)=yj*fac
1545             gg(3)=zj*fac
1546 C Calculate angular part of the gradient.
1547             call sc_grad
1548             ENDIF    ! dyn_ss
1549           enddo      ! j
1550         enddo        ! iint
1551       enddo          ! i
1552 c      write (iout,*) "Number of loop steps in EGB:",ind
1553 cccc      energy_dec=.false.
1554       return
1555       end
1556 C-----------------------------------------------------------------------------
1557       subroutine egbv(evdw)
1558 C
1559 C This subroutine calculates the interaction energy of nonbonded side chains
1560 C assuming the Gay-Berne-Vorobjev potential of interaction.
1561 C
1562       implicit real*8 (a-h,o-z)
1563       include 'DIMENSIONS'
1564       include 'COMMON.GEO'
1565       include 'COMMON.VAR'
1566       include 'COMMON.LOCAL'
1567       include 'COMMON.CHAIN'
1568       include 'COMMON.DERIV'
1569       include 'COMMON.NAMES'
1570       include 'COMMON.INTERACT'
1571       include 'COMMON.IOUNITS'
1572       include 'COMMON.CALC'
1573       common /srutu/ icall
1574       logical lprn
1575       evdw=0.0D0
1576 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1577       evdw=0.0D0
1578       lprn=.false.
1579 c     if (icall.eq.0) lprn=.true.
1580       ind=0
1581       do i=iatsc_s,iatsc_e
1582         itypi=itype(i)
1583         if (itypi.eq.21) cycle
1584         itypi1=itype(i+1)
1585         xi=c(1,nres+i)
1586         yi=c(2,nres+i)
1587         zi=c(3,nres+i)
1588         dxi=dc_norm(1,nres+i)
1589         dyi=dc_norm(2,nres+i)
1590         dzi=dc_norm(3,nres+i)
1591 c        dsci_inv=dsc_inv(itypi)
1592         dsci_inv=vbld_inv(i+nres)
1593 C
1594 C Calculate SC interaction energy.
1595 C
1596         do iint=1,nint_gr(i)
1597           do j=istart(i,iint),iend(i,iint)
1598             ind=ind+1
1599             itypj=itype(j)
1600             if (itypj.eq.21) cycle
1601 c            dscj_inv=dsc_inv(itypj)
1602             dscj_inv=vbld_inv(j+nres)
1603             sig0ij=sigma(itypi,itypj)
1604             r0ij=r0(itypi,itypj)
1605             chi1=chi(itypi,itypj)
1606             chi2=chi(itypj,itypi)
1607             chi12=chi1*chi2
1608             chip1=chip(itypi)
1609             chip2=chip(itypj)
1610             chip12=chip1*chip2
1611             alf1=alp(itypi)
1612             alf2=alp(itypj)
1613             alf12=0.5D0*(alf1+alf2)
1614 C For diagnostics only!!!
1615 c           chi1=0.0D0
1616 c           chi2=0.0D0
1617 c           chi12=0.0D0
1618 c           chip1=0.0D0
1619 c           chip2=0.0D0
1620 c           chip12=0.0D0
1621 c           alf1=0.0D0
1622 c           alf2=0.0D0
1623 c           alf12=0.0D0
1624             xj=c(1,nres+j)-xi
1625             yj=c(2,nres+j)-yi
1626             zj=c(3,nres+j)-zi
1627             dxj=dc_norm(1,nres+j)
1628             dyj=dc_norm(2,nres+j)
1629             dzj=dc_norm(3,nres+j)
1630             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1631             rij=dsqrt(rrij)
1632 C Calculate angle-dependent terms of energy and contributions to their
1633 C derivatives.
1634             call sc_angular
1635             sigsq=1.0D0/sigsq
1636             sig=sig0ij*dsqrt(sigsq)
1637             rij_shift=1.0D0/rij-sig+r0ij
1638 C I hate to put IF's in the loops, but here don't have another choice!!!!
1639             if (rij_shift.le.0.0D0) then
1640               evdw=1.0D20
1641               return
1642             endif
1643             sigder=-sig*sigsq
1644 c---------------------------------------------------------------
1645             rij_shift=1.0D0/rij_shift
1646             fac=rij_shift**expon
1647             e1=fac*fac*aa(itypi,itypj)
1648             e2=fac*bb(itypi,itypj)
1649             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1650             eps2der=evdwij*eps3rt
1651             eps3der=evdwij*eps2rt
1652             fac_augm=rrij**expon
1653             e_augm=augm(itypi,itypj)*fac_augm
1654             evdwij=evdwij*eps2rt*eps3rt
1655             evdw=evdw+evdwij+e_augm
1656             if (lprn) then
1657             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1658             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1659             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1660      &        restyp(itypi),i,restyp(itypj),j,
1661      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1662      &        chi1,chi2,chip1,chip2,
1663      &        eps1,eps2rt**2,eps3rt**2,
1664      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1665      &        evdwij+e_augm
1666             endif
1667 C Calculate gradient components.
1668             e1=e1*eps1*eps2rt**2*eps3rt**2
1669             fac=-expon*(e1+evdwij)*rij_shift
1670             sigder=fac*sigder
1671             fac=rij*fac-2*expon*rrij*e_augm
1672 C Calculate the radial part of the gradient
1673             gg(1)=xj*fac
1674             gg(2)=yj*fac
1675             gg(3)=zj*fac
1676 C Calculate angular part of the gradient.
1677             call sc_grad
1678           enddo      ! j
1679         enddo        ! iint
1680       enddo          ! i
1681       end
1682 C-----------------------------------------------------------------------------
1683       subroutine sc_angular
1684 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1685 C om12. Called by ebp, egb, and egbv.
1686       implicit none
1687       include 'COMMON.CALC'
1688       include 'COMMON.IOUNITS'
1689       erij(1)=xj*rij
1690       erij(2)=yj*rij
1691       erij(3)=zj*rij
1692       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1693       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1694       om12=dxi*dxj+dyi*dyj+dzi*dzj
1695       chiom12=chi12*om12
1696 C Calculate eps1(om12) and its derivative in om12
1697       faceps1=1.0D0-om12*chiom12
1698       faceps1_inv=1.0D0/faceps1
1699       eps1=dsqrt(faceps1_inv)
1700 C Following variable is eps1*deps1/dom12
1701       eps1_om12=faceps1_inv*chiom12
1702 c diagnostics only
1703 c      faceps1_inv=om12
1704 c      eps1=om12
1705 c      eps1_om12=1.0d0
1706 c      write (iout,*) "om12",om12," eps1",eps1
1707 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1708 C and om12.
1709       om1om2=om1*om2
1710       chiom1=chi1*om1
1711       chiom2=chi2*om2
1712       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1713       sigsq=1.0D0-facsig*faceps1_inv
1714       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1715       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1716       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1717 c diagnostics only
1718 c      sigsq=1.0d0
1719 c      sigsq_om1=0.0d0
1720 c      sigsq_om2=0.0d0
1721 c      sigsq_om12=0.0d0
1722 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1723 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1724 c     &    " eps1",eps1
1725 C Calculate eps2 and its derivatives in om1, om2, and om12.
1726       chipom1=chip1*om1
1727       chipom2=chip2*om2
1728       chipom12=chip12*om12
1729       facp=1.0D0-om12*chipom12
1730       facp_inv=1.0D0/facp
1731       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1732 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1733 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1734 C Following variable is the square root of eps2
1735       eps2rt=1.0D0-facp1*facp_inv
1736 C Following three variables are the derivatives of the square root of eps
1737 C in om1, om2, and om12.
1738       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1739       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1740       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1741 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1742       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1743 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1744 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1745 c     &  " eps2rt_om12",eps2rt_om12
1746 C Calculate whole angle-dependent part of epsilon and contributions
1747 C to its derivatives
1748       return
1749       end
1750 C----------------------------------------------------------------------------
1751       subroutine sc_grad
1752       implicit real*8 (a-h,o-z)
1753       include 'DIMENSIONS'
1754       include 'COMMON.CHAIN'
1755       include 'COMMON.DERIV'
1756       include 'COMMON.CALC'
1757       include 'COMMON.IOUNITS'
1758       double precision dcosom1(3),dcosom2(3)
1759       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1760       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1761       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1762      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1763 c diagnostics only
1764 c      eom1=0.0d0
1765 c      eom2=0.0d0
1766 c      eom12=evdwij*eps1_om12
1767 c end diagnostics
1768 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1769 c     &  " sigder",sigder
1770 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1771 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1772       do k=1,3
1773         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1774         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1775       enddo
1776       do k=1,3
1777         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1778       enddo
1779 c      write (iout,*) "gg",(gg(k),k=1,3)
1780       do k=1,3
1781         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1782      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1783      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1784         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1785      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1786      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1787 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1788 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1789 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1790 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1791       enddo
1792 C
1793 C Calculate the components of the gradient in DC and X
1794 C
1795 cgrad      do k=i,j-1
1796 cgrad        do l=1,3
1797 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1798 cgrad        enddo
1799 cgrad      enddo
1800       do l=1,3
1801         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1802         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1803       enddo
1804       return
1805       end
1806 C-----------------------------------------------------------------------
1807       subroutine e_softsphere(evdw)
1808 C
1809 C This subroutine calculates the interaction energy of nonbonded side chains
1810 C assuming the LJ potential of interaction.
1811 C
1812       implicit real*8 (a-h,o-z)
1813       include 'DIMENSIONS'
1814       parameter (accur=1.0d-10)
1815       include 'COMMON.GEO'
1816       include 'COMMON.VAR'
1817       include 'COMMON.LOCAL'
1818       include 'COMMON.CHAIN'
1819       include 'COMMON.DERIV'
1820       include 'COMMON.INTERACT'
1821       include 'COMMON.TORSION'
1822       include 'COMMON.SBRIDGE'
1823       include 'COMMON.NAMES'
1824       include 'COMMON.IOUNITS'
1825       include 'COMMON.CONTACTS'
1826       dimension gg(3)
1827 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1828       evdw=0.0D0
1829       do i=iatsc_s,iatsc_e
1830         itypi=itype(i)
1831         if (itypi.eq.21) cycle
1832         itypi1=itype(i+1)
1833         xi=c(1,nres+i)
1834         yi=c(2,nres+i)
1835         zi=c(3,nres+i)
1836 C
1837 C Calculate SC interaction energy.
1838 C
1839         do iint=1,nint_gr(i)
1840 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1841 cd   &                  'iend=',iend(i,iint)
1842           do j=istart(i,iint),iend(i,iint)
1843             itypj=itype(j)
1844             if (itypj.eq.21) cycle
1845             xj=c(1,nres+j)-xi
1846             yj=c(2,nres+j)-yi
1847             zj=c(3,nres+j)-zi
1848             rij=xj*xj+yj*yj+zj*zj
1849 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1850             r0ij=r0(itypi,itypj)
1851             r0ijsq=r0ij*r0ij
1852 c            print *,i,j,r0ij,dsqrt(rij)
1853             if (rij.lt.r0ijsq) then
1854               evdwij=0.25d0*(rij-r0ijsq)**2
1855               fac=rij-r0ijsq
1856             else
1857               evdwij=0.0d0
1858               fac=0.0d0
1859             endif
1860             evdw=evdw+evdwij
1861 C
1862 C Calculate the components of the gradient in DC and X
1863 C
1864             gg(1)=xj*fac
1865             gg(2)=yj*fac
1866             gg(3)=zj*fac
1867             do k=1,3
1868               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1869               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1870               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1871               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1872             enddo
1873 cgrad            do k=i,j-1
1874 cgrad              do l=1,3
1875 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1876 cgrad              enddo
1877 cgrad            enddo
1878           enddo ! j
1879         enddo ! iint
1880       enddo ! i
1881       return
1882       end
1883 C--------------------------------------------------------------------------
1884       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1885      &              eello_turn4)
1886 C
1887 C Soft-sphere potential of p-p interaction
1888 C
1889       implicit real*8 (a-h,o-z)
1890       include 'DIMENSIONS'
1891       include 'COMMON.CONTROL'
1892       include 'COMMON.IOUNITS'
1893       include 'COMMON.GEO'
1894       include 'COMMON.VAR'
1895       include 'COMMON.LOCAL'
1896       include 'COMMON.CHAIN'
1897       include 'COMMON.DERIV'
1898       include 'COMMON.INTERACT'
1899       include 'COMMON.CONTACTS'
1900       include 'COMMON.TORSION'
1901       include 'COMMON.VECTORS'
1902       include 'COMMON.FFIELD'
1903       dimension ggg(3)
1904 cd      write(iout,*) 'In EELEC_soft_sphere'
1905       ees=0.0D0
1906       evdw1=0.0D0
1907       eel_loc=0.0d0
1908       eello_turn3=0.0d0
1909       eello_turn4=0.0d0
1910       ind=0
1911       do i=iatel_s,iatel_e
1912         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
1913         dxi=dc(1,i)
1914         dyi=dc(2,i)
1915         dzi=dc(3,i)
1916         xmedi=c(1,i)+0.5d0*dxi
1917         ymedi=c(2,i)+0.5d0*dyi
1918         zmedi=c(3,i)+0.5d0*dzi
1919         num_conti=0
1920 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1921         do j=ielstart(i),ielend(i)
1922           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
1923           ind=ind+1
1924           iteli=itel(i)
1925           itelj=itel(j)
1926           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1927           r0ij=rpp(iteli,itelj)
1928           r0ijsq=r0ij*r0ij
1929           dxj=dc(1,j)
1930           dyj=dc(2,j)
1931           dzj=dc(3,j)
1932           xj=c(1,j)+0.5D0*dxj-xmedi
1933           yj=c(2,j)+0.5D0*dyj-ymedi
1934           zj=c(3,j)+0.5D0*dzj-zmedi
1935           rij=xj*xj+yj*yj+zj*zj
1936           if (rij.lt.r0ijsq) then
1937             evdw1ij=0.25d0*(rij-r0ijsq)**2
1938             fac=rij-r0ijsq
1939           else
1940             evdw1ij=0.0d0
1941             fac=0.0d0
1942           endif
1943           evdw1=evdw1+evdw1ij
1944 C
1945 C Calculate contributions to the Cartesian gradient.
1946 C
1947           ggg(1)=fac*xj
1948           ggg(2)=fac*yj
1949           ggg(3)=fac*zj
1950           do k=1,3
1951             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1952             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1953           enddo
1954 *
1955 * Loop over residues i+1 thru j-1.
1956 *
1957 cgrad          do k=i+1,j-1
1958 cgrad            do l=1,3
1959 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1960 cgrad            enddo
1961 cgrad          enddo
1962         enddo ! j
1963       enddo   ! i
1964 cgrad      do i=nnt,nct-1
1965 cgrad        do k=1,3
1966 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
1967 cgrad        enddo
1968 cgrad        do j=i+1,nct-1
1969 cgrad          do k=1,3
1970 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
1971 cgrad          enddo
1972 cgrad        enddo
1973 cgrad      enddo
1974       return
1975       end
1976 c------------------------------------------------------------------------------
1977       subroutine vec_and_deriv
1978       implicit real*8 (a-h,o-z)
1979       include 'DIMENSIONS'
1980 #ifdef MPI
1981       include 'mpif.h'
1982 #endif
1983       include 'COMMON.IOUNITS'
1984       include 'COMMON.GEO'
1985       include 'COMMON.VAR'
1986       include 'COMMON.LOCAL'
1987       include 'COMMON.CHAIN'
1988       include 'COMMON.VECTORS'
1989       include 'COMMON.SETUP'
1990       include 'COMMON.TIME1'
1991       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1992 C Compute the local reference systems. For reference system (i), the
1993 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1994 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1995 #ifdef PARVEC
1996       do i=ivec_start,ivec_end
1997 #else
1998       do i=1,nres-1
1999 #endif
2000           if (i.eq.nres-1) then
2001 C Case of the last full residue
2002 C Compute the Z-axis
2003             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2004             costh=dcos(pi-theta(nres))
2005             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2006             do k=1,3
2007               uz(k,i)=fac*uz(k,i)
2008             enddo
2009 C Compute the derivatives of uz
2010             uzder(1,1,1)= 0.0d0
2011             uzder(2,1,1)=-dc_norm(3,i-1)
2012             uzder(3,1,1)= dc_norm(2,i-1)
2013             uzder(1,2,1)= dc_norm(3,i-1)
2014             uzder(2,2,1)= 0.0d0
2015             uzder(3,2,1)=-dc_norm(1,i-1)
2016             uzder(1,3,1)=-dc_norm(2,i-1)
2017             uzder(2,3,1)= dc_norm(1,i-1)
2018             uzder(3,3,1)= 0.0d0
2019             uzder(1,1,2)= 0.0d0
2020             uzder(2,1,2)= dc_norm(3,i)
2021             uzder(3,1,2)=-dc_norm(2,i)
2022             uzder(1,2,2)=-dc_norm(3,i)
2023             uzder(2,2,2)= 0.0d0
2024             uzder(3,2,2)= dc_norm(1,i)
2025             uzder(1,3,2)= dc_norm(2,i)
2026             uzder(2,3,2)=-dc_norm(1,i)
2027             uzder(3,3,2)= 0.0d0
2028 C Compute the Y-axis
2029             facy=fac
2030             do k=1,3
2031               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2032             enddo
2033 C Compute the derivatives of uy
2034             do j=1,3
2035               do k=1,3
2036                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2037      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2038                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2039               enddo
2040               uyder(j,j,1)=uyder(j,j,1)-costh
2041               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2042             enddo
2043             do j=1,2
2044               do k=1,3
2045                 do l=1,3
2046                   uygrad(l,k,j,i)=uyder(l,k,j)
2047                   uzgrad(l,k,j,i)=uzder(l,k,j)
2048                 enddo
2049               enddo
2050             enddo
2051             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2052             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2053             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2054             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2055           else
2056 C Other residues
2057 C Compute the Z-axis
2058             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2059             costh=dcos(pi-theta(i+2))
2060             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2061             do k=1,3
2062               uz(k,i)=fac*uz(k,i)
2063             enddo
2064 C Compute the derivatives of uz
2065             uzder(1,1,1)= 0.0d0
2066             uzder(2,1,1)=-dc_norm(3,i+1)
2067             uzder(3,1,1)= dc_norm(2,i+1)
2068             uzder(1,2,1)= dc_norm(3,i+1)
2069             uzder(2,2,1)= 0.0d0
2070             uzder(3,2,1)=-dc_norm(1,i+1)
2071             uzder(1,3,1)=-dc_norm(2,i+1)
2072             uzder(2,3,1)= dc_norm(1,i+1)
2073             uzder(3,3,1)= 0.0d0
2074             uzder(1,1,2)= 0.0d0
2075             uzder(2,1,2)= dc_norm(3,i)
2076             uzder(3,1,2)=-dc_norm(2,i)
2077             uzder(1,2,2)=-dc_norm(3,i)
2078             uzder(2,2,2)= 0.0d0
2079             uzder(3,2,2)= dc_norm(1,i)
2080             uzder(1,3,2)= dc_norm(2,i)
2081             uzder(2,3,2)=-dc_norm(1,i)
2082             uzder(3,3,2)= 0.0d0
2083 C Compute the Y-axis
2084             facy=fac
2085             do k=1,3
2086               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2087             enddo
2088 C Compute the derivatives of uy
2089             do j=1,3
2090               do k=1,3
2091                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2092      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2093                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2094               enddo
2095               uyder(j,j,1)=uyder(j,j,1)-costh
2096               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2097             enddo
2098             do j=1,2
2099               do k=1,3
2100                 do l=1,3
2101                   uygrad(l,k,j,i)=uyder(l,k,j)
2102                   uzgrad(l,k,j,i)=uzder(l,k,j)
2103                 enddo
2104               enddo
2105             enddo
2106             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2107             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2108             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2109             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2110           endif
2111       enddo
2112       do i=1,nres-1
2113         vbld_inv_temp(1)=vbld_inv(i+1)
2114         if (i.lt.nres-1) then
2115           vbld_inv_temp(2)=vbld_inv(i+2)
2116           else
2117           vbld_inv_temp(2)=vbld_inv(i)
2118           endif
2119         do j=1,2
2120           do k=1,3
2121             do l=1,3
2122               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2123               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2124             enddo
2125           enddo
2126         enddo
2127       enddo
2128 #if defined(PARVEC) && defined(MPI)
2129       if (nfgtasks1.gt.1) then
2130         time00=MPI_Wtime()
2131 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2132 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2133 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2134         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2135      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2136      &   FG_COMM1,IERR)
2137         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2138      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2139      &   FG_COMM1,IERR)
2140         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2141      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2142      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2143         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2144      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2145      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2146         time_gather=time_gather+MPI_Wtime()-time00
2147       endif
2148 c      if (fg_rank.eq.0) then
2149 c        write (iout,*) "Arrays UY and UZ"
2150 c        do i=1,nres-1
2151 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2152 c     &     (uz(k,i),k=1,3)
2153 c        enddo
2154 c      endif
2155 #endif
2156       return
2157       end
2158 C-----------------------------------------------------------------------------
2159       subroutine check_vecgrad
2160       implicit real*8 (a-h,o-z)
2161       include 'DIMENSIONS'
2162       include 'COMMON.IOUNITS'
2163       include 'COMMON.GEO'
2164       include 'COMMON.VAR'
2165       include 'COMMON.LOCAL'
2166       include 'COMMON.CHAIN'
2167       include 'COMMON.VECTORS'
2168       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2169       dimension uyt(3,maxres),uzt(3,maxres)
2170       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2171       double precision delta /1.0d-7/
2172       call vec_and_deriv
2173 cd      do i=1,nres
2174 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2175 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2176 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2177 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2178 cd     &     (dc_norm(if90,i),if90=1,3)
2179 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2180 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2181 cd          write(iout,'(a)')
2182 cd      enddo
2183       do i=1,nres
2184         do j=1,2
2185           do k=1,3
2186             do l=1,3
2187               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2188               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2189             enddo
2190           enddo
2191         enddo
2192       enddo
2193       call vec_and_deriv
2194       do i=1,nres
2195         do j=1,3
2196           uyt(j,i)=uy(j,i)
2197           uzt(j,i)=uz(j,i)
2198         enddo
2199       enddo
2200       do i=1,nres
2201 cd        write (iout,*) 'i=',i
2202         do k=1,3
2203           erij(k)=dc_norm(k,i)
2204         enddo
2205         do j=1,3
2206           do k=1,3
2207             dc_norm(k,i)=erij(k)
2208           enddo
2209           dc_norm(j,i)=dc_norm(j,i)+delta
2210 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2211 c          do k=1,3
2212 c            dc_norm(k,i)=dc_norm(k,i)/fac
2213 c          enddo
2214 c          write (iout,*) (dc_norm(k,i),k=1,3)
2215 c          write (iout,*) (erij(k),k=1,3)
2216           call vec_and_deriv
2217           do k=1,3
2218             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2219             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2220             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2221             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2222           enddo
2223 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2224 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2225 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2226         enddo
2227         do k=1,3
2228           dc_norm(k,i)=erij(k)
2229         enddo
2230 cd        do k=1,3
2231 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2232 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2233 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2234 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2235 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2236 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2237 cd          write (iout,'(a)')
2238 cd        enddo
2239       enddo
2240       return
2241       end
2242 C--------------------------------------------------------------------------
2243       subroutine set_matrices
2244       implicit real*8 (a-h,o-z)
2245       include 'DIMENSIONS'
2246 #ifdef MPI
2247       include "mpif.h"
2248       include "COMMON.SETUP"
2249       integer IERR
2250       integer status(MPI_STATUS_SIZE)
2251 #endif
2252       include 'COMMON.IOUNITS'
2253       include 'COMMON.GEO'
2254       include 'COMMON.VAR'
2255       include 'COMMON.LOCAL'
2256       include 'COMMON.CHAIN'
2257       include 'COMMON.DERIV'
2258       include 'COMMON.INTERACT'
2259       include 'COMMON.CONTACTS'
2260       include 'COMMON.TORSION'
2261       include 'COMMON.VECTORS'
2262       include 'COMMON.FFIELD'
2263       double precision auxvec(2),auxmat(2,2)
2264 C
2265 C Compute the virtual-bond-torsional-angle dependent quantities needed
2266 C to calculate the el-loc multibody terms of various order.
2267 C
2268 #ifdef PARMAT
2269       do i=ivec_start+2,ivec_end+2
2270 #else
2271       do i=3,nres+1
2272 #endif
2273         if (i .lt. nres+1) then
2274           sin1=dsin(phi(i))
2275           cos1=dcos(phi(i))
2276           sintab(i-2)=sin1
2277           costab(i-2)=cos1
2278           obrot(1,i-2)=cos1
2279           obrot(2,i-2)=sin1
2280           sin2=dsin(2*phi(i))
2281           cos2=dcos(2*phi(i))
2282           sintab2(i-2)=sin2
2283           costab2(i-2)=cos2
2284           obrot2(1,i-2)=cos2
2285           obrot2(2,i-2)=sin2
2286           Ug(1,1,i-2)=-cos1
2287           Ug(1,2,i-2)=-sin1
2288           Ug(2,1,i-2)=-sin1
2289           Ug(2,2,i-2)= cos1
2290           Ug2(1,1,i-2)=-cos2
2291           Ug2(1,2,i-2)=-sin2
2292           Ug2(2,1,i-2)=-sin2
2293           Ug2(2,2,i-2)= cos2
2294         else
2295           costab(i-2)=1.0d0
2296           sintab(i-2)=0.0d0
2297           obrot(1,i-2)=1.0d0
2298           obrot(2,i-2)=0.0d0
2299           obrot2(1,i-2)=0.0d0
2300           obrot2(2,i-2)=0.0d0
2301           Ug(1,1,i-2)=1.0d0
2302           Ug(1,2,i-2)=0.0d0
2303           Ug(2,1,i-2)=0.0d0
2304           Ug(2,2,i-2)=1.0d0
2305           Ug2(1,1,i-2)=0.0d0
2306           Ug2(1,2,i-2)=0.0d0
2307           Ug2(2,1,i-2)=0.0d0
2308           Ug2(2,2,i-2)=0.0d0
2309         endif
2310         if (i .gt. 3 .and. i .lt. nres+1) then
2311           obrot_der(1,i-2)=-sin1
2312           obrot_der(2,i-2)= cos1
2313           Ugder(1,1,i-2)= sin1
2314           Ugder(1,2,i-2)=-cos1
2315           Ugder(2,1,i-2)=-cos1
2316           Ugder(2,2,i-2)=-sin1
2317           dwacos2=cos2+cos2
2318           dwasin2=sin2+sin2
2319           obrot2_der(1,i-2)=-dwasin2
2320           obrot2_der(2,i-2)= dwacos2
2321           Ug2der(1,1,i-2)= dwasin2
2322           Ug2der(1,2,i-2)=-dwacos2
2323           Ug2der(2,1,i-2)=-dwacos2
2324           Ug2der(2,2,i-2)=-dwasin2
2325         else
2326           obrot_der(1,i-2)=0.0d0
2327           obrot_der(2,i-2)=0.0d0
2328           Ugder(1,1,i-2)=0.0d0
2329           Ugder(1,2,i-2)=0.0d0
2330           Ugder(2,1,i-2)=0.0d0
2331           Ugder(2,2,i-2)=0.0d0
2332           obrot2_der(1,i-2)=0.0d0
2333           obrot2_der(2,i-2)=0.0d0
2334           Ug2der(1,1,i-2)=0.0d0
2335           Ug2der(1,2,i-2)=0.0d0
2336           Ug2der(2,1,i-2)=0.0d0
2337           Ug2der(2,2,i-2)=0.0d0
2338         endif
2339 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2340         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2341           iti = itortyp(itype(i-2))
2342         else
2343           iti=ntortyp+1
2344         endif
2345 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2346         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2347           iti1 = itortyp(itype(i-1))
2348         else
2349           iti1=ntortyp+1
2350         endif
2351 cd        write (iout,*) '*******i',i,' iti1',iti
2352 cd        write (iout,*) 'b1',b1(:,iti)
2353 cd        write (iout,*) 'b2',b2(:,iti)
2354 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2355 c        if (i .gt. iatel_s+2) then
2356         if (i .gt. nnt+2) then
2357           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2358           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2359           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2360      &    then
2361           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2362           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2363           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2364           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2365           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2366           endif
2367         else
2368           do k=1,2
2369             Ub2(k,i-2)=0.0d0
2370             Ctobr(k,i-2)=0.0d0
2371             Dtobr2(k,i-2)=0.0d0
2372             do l=1,2
2373               EUg(l,k,i-2)=0.0d0
2374               CUg(l,k,i-2)=0.0d0
2375               DUg(l,k,i-2)=0.0d0
2376               DtUg2(l,k,i-2)=0.0d0
2377             enddo
2378           enddo
2379         endif
2380         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2381         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2382         do k=1,2
2383           muder(k,i-2)=Ub2der(k,i-2)
2384         enddo
2385 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2386         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2387           iti1 = itortyp(itype(i-1))
2388         else
2389           iti1=ntortyp+1
2390         endif
2391         do k=1,2
2392           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2393         enddo
2394 cd        write (iout,*) 'mu ',mu(:,i-2)
2395 cd        write (iout,*) 'mu1',mu1(:,i-2)
2396 cd        write (iout,*) 'mu2',mu2(:,i-2)
2397         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2398      &  then
2399         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2400         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2401         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2402         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2403         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2404 C Vectors and matrices dependent on a single virtual-bond dihedral.
2405         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2406         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2407         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2408         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2409         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2410         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2411         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2412         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2413         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2414         endif
2415       enddo
2416 C Matrices dependent on two consecutive virtual-bond dihedrals.
2417 C The order of matrices is from left to right.
2418       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2419      &then
2420 c      do i=max0(ivec_start,2),ivec_end
2421       do i=2,nres-1
2422         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2423         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2424         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2425         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2426         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2427         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2428         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2429         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2430       enddo
2431       endif
2432 #if defined(MPI) && defined(PARMAT)
2433 #ifdef DEBUG
2434 c      if (fg_rank.eq.0) then
2435         write (iout,*) "Arrays UG and UGDER before GATHER"
2436         do i=1,nres-1
2437           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2438      &     ((ug(l,k,i),l=1,2),k=1,2),
2439      &     ((ugder(l,k,i),l=1,2),k=1,2)
2440         enddo
2441         write (iout,*) "Arrays UG2 and UG2DER"
2442         do i=1,nres-1
2443           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2444      &     ((ug2(l,k,i),l=1,2),k=1,2),
2445      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2446         enddo
2447         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2448         do i=1,nres-1
2449           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2450      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2451      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2452         enddo
2453         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2454         do i=1,nres-1
2455           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2456      &     costab(i),sintab(i),costab2(i),sintab2(i)
2457         enddo
2458         write (iout,*) "Array MUDER"
2459         do i=1,nres-1
2460           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2461         enddo
2462 c      endif
2463 #endif
2464       if (nfgtasks.gt.1) then
2465         time00=MPI_Wtime()
2466 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2467 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2468 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2469 #ifdef MATGATHER
2470         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2471      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2472      &   FG_COMM1,IERR)
2473         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2474      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2475      &   FG_COMM1,IERR)
2476         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2477      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2478      &   FG_COMM1,IERR)
2479         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2480      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2481      &   FG_COMM1,IERR)
2482         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2483      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2484      &   FG_COMM1,IERR)
2485         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2486      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2487      &   FG_COMM1,IERR)
2488         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2489      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2490      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2491         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2492      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2493      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2494         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2495      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2496      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2497         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2498      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2499      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2500         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2501      &  then
2502         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2503      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2504      &   FG_COMM1,IERR)
2505         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2506      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2507      &   FG_COMM1,IERR)
2508         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2509      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2510      &   FG_COMM1,IERR)
2511        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2512      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2513      &   FG_COMM1,IERR)
2514         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2515      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2516      &   FG_COMM1,IERR)
2517         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2518      &   ivec_count(fg_rank1),
2519      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2520      &   FG_COMM1,IERR)
2521         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2522      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2523      &   FG_COMM1,IERR)
2524         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2525      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2526      &   FG_COMM1,IERR)
2527         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2528      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2529      &   FG_COMM1,IERR)
2530         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2531      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2532      &   FG_COMM1,IERR)
2533         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2534      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2535      &   FG_COMM1,IERR)
2536         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2537      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2538      &   FG_COMM1,IERR)
2539         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2540      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2541      &   FG_COMM1,IERR)
2542         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2543      &   ivec_count(fg_rank1),
2544      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2545      &   FG_COMM1,IERR)
2546         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2547      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2548      &   FG_COMM1,IERR)
2549        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2550      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2551      &   FG_COMM1,IERR)
2552         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2553      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2554      &   FG_COMM1,IERR)
2555        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2556      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2557      &   FG_COMM1,IERR)
2558         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2559      &   ivec_count(fg_rank1),
2560      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2561      &   FG_COMM1,IERR)
2562         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2563      &   ivec_count(fg_rank1),
2564      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2565      &   FG_COMM1,IERR)
2566         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2567      &   ivec_count(fg_rank1),
2568      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2569      &   MPI_MAT2,FG_COMM1,IERR)
2570         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2571      &   ivec_count(fg_rank1),
2572      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2573      &   MPI_MAT2,FG_COMM1,IERR)
2574         endif
2575 #else
2576 c Passes matrix info through the ring
2577       isend=fg_rank1
2578       irecv=fg_rank1-1
2579       if (irecv.lt.0) irecv=nfgtasks1-1
2580       iprev=irecv
2581       inext=fg_rank1+1
2582       if (inext.ge.nfgtasks1) inext=0
2583       do i=1,nfgtasks1-1
2584 c        write (iout,*) "isend",isend," irecv",irecv
2585 c        call flush(iout)
2586         lensend=lentyp(isend)
2587         lenrecv=lentyp(irecv)
2588 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2589 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2590 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2591 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2592 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2593 c        write (iout,*) "Gather ROTAT1"
2594 c        call flush(iout)
2595 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2596 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2597 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2598 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2599 c        write (iout,*) "Gather ROTAT2"
2600 c        call flush(iout)
2601         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2602      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2603      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2604      &   iprev,4400+irecv,FG_COMM,status,IERR)
2605 c        write (iout,*) "Gather ROTAT_OLD"
2606 c        call flush(iout)
2607         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2608      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2609      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2610      &   iprev,5500+irecv,FG_COMM,status,IERR)
2611 c        write (iout,*) "Gather PRECOMP11"
2612 c        call flush(iout)
2613         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2614      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2615      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2616      &   iprev,6600+irecv,FG_COMM,status,IERR)
2617 c        write (iout,*) "Gather PRECOMP12"
2618 c        call flush(iout)
2619         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2620      &  then
2621         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2622      &   MPI_ROTAT2(lensend),inext,7700+isend,
2623      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2624      &   iprev,7700+irecv,FG_COMM,status,IERR)
2625 c        write (iout,*) "Gather PRECOMP21"
2626 c        call flush(iout)
2627         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2628      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2629      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2630      &   iprev,8800+irecv,FG_COMM,status,IERR)
2631 c        write (iout,*) "Gather PRECOMP22"
2632 c        call flush(iout)
2633         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2634      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2635      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2636      &   MPI_PRECOMP23(lenrecv),
2637      &   iprev,9900+irecv,FG_COMM,status,IERR)
2638 c        write (iout,*) "Gather PRECOMP23"
2639 c        call flush(iout)
2640         endif
2641         isend=irecv
2642         irecv=irecv-1
2643         if (irecv.lt.0) irecv=nfgtasks1-1
2644       enddo
2645 #endif
2646         time_gather=time_gather+MPI_Wtime()-time00
2647       endif
2648 #ifdef DEBUG
2649 c      if (fg_rank.eq.0) then
2650         write (iout,*) "Arrays UG and UGDER"
2651         do i=1,nres-1
2652           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2653      &     ((ug(l,k,i),l=1,2),k=1,2),
2654      &     ((ugder(l,k,i),l=1,2),k=1,2)
2655         enddo
2656         write (iout,*) "Arrays UG2 and UG2DER"
2657         do i=1,nres-1
2658           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2659      &     ((ug2(l,k,i),l=1,2),k=1,2),
2660      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2661         enddo
2662         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2663         do i=1,nres-1
2664           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2665      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2666      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2667         enddo
2668         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2669         do i=1,nres-1
2670           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2671      &     costab(i),sintab(i),costab2(i),sintab2(i)
2672         enddo
2673         write (iout,*) "Array MUDER"
2674         do i=1,nres-1
2675           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2676         enddo
2677 c      endif
2678 #endif
2679 #endif
2680 cd      do i=1,nres
2681 cd        iti = itortyp(itype(i))
2682 cd        write (iout,*) i
2683 cd        do j=1,2
2684 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2685 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2686 cd        enddo
2687 cd      enddo
2688       return
2689       end
2690 C--------------------------------------------------------------------------
2691       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2692 C
2693 C This subroutine calculates the average interaction energy and its gradient
2694 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2695 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2696 C The potential depends both on the distance of peptide-group centers and on
2697 C the orientation of the CA-CA virtual bonds.
2698 C
2699       implicit real*8 (a-h,o-z)
2700 #ifdef MPI
2701       include 'mpif.h'
2702 #endif
2703       include 'DIMENSIONS'
2704       include 'COMMON.CONTROL'
2705       include 'COMMON.SETUP'
2706       include 'COMMON.IOUNITS'
2707       include 'COMMON.GEO'
2708       include 'COMMON.VAR'
2709       include 'COMMON.LOCAL'
2710       include 'COMMON.CHAIN'
2711       include 'COMMON.DERIV'
2712       include 'COMMON.INTERACT'
2713       include 'COMMON.CONTACTS'
2714       include 'COMMON.TORSION'
2715       include 'COMMON.VECTORS'
2716       include 'COMMON.FFIELD'
2717       include 'COMMON.TIME1'
2718       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2719      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2720       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2721      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2722       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2723      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2724      &    num_conti,j1,j2
2725 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2726 #ifdef MOMENT
2727       double precision scal_el /1.0d0/
2728 #else
2729       double precision scal_el /0.5d0/
2730 #endif
2731 C 12/13/98
2732 C 13-go grudnia roku pamietnego...
2733       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2734      &                   0.0d0,1.0d0,0.0d0,
2735      &                   0.0d0,0.0d0,1.0d0/
2736 cd      write(iout,*) 'In EELEC'
2737 cd      do i=1,nloctyp
2738 cd        write(iout,*) 'Type',i
2739 cd        write(iout,*) 'B1',B1(:,i)
2740 cd        write(iout,*) 'B2',B2(:,i)
2741 cd        write(iout,*) 'CC',CC(:,:,i)
2742 cd        write(iout,*) 'DD',DD(:,:,i)
2743 cd        write(iout,*) 'EE',EE(:,:,i)
2744 cd      enddo
2745 cd      call check_vecgrad
2746 cd      stop
2747       if (icheckgrad.eq.1) then
2748         do i=1,nres-1
2749           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2750           do k=1,3
2751             dc_norm(k,i)=dc(k,i)*fac
2752           enddo
2753 c          write (iout,*) 'i',i,' fac',fac
2754         enddo
2755       endif
2756       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2757      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2758      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2759 c        call vec_and_deriv
2760 #ifdef TIMING
2761         time01=MPI_Wtime()
2762 #endif
2763         call set_matrices
2764 #ifdef TIMING
2765         time_mat=time_mat+MPI_Wtime()-time01
2766 #endif
2767       endif
2768 cd      do i=1,nres-1
2769 cd        write (iout,*) 'i=',i
2770 cd        do k=1,3
2771 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2772 cd        enddo
2773 cd        do k=1,3
2774 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2775 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2776 cd        enddo
2777 cd      enddo
2778       t_eelecij=0.0d0
2779       ees=0.0D0
2780       evdw1=0.0D0
2781       eel_loc=0.0d0
2782       eello_turn3=0.0d0
2783       eello_turn4=0.0d0
2784       ind=0
2785       do i=1,nres
2786         num_cont_hb(i)=0
2787       enddo
2788 cd      print '(a)','Enter EELEC'
2789 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2790       do i=1,nres
2791         gel_loc_loc(i)=0.0d0
2792         gcorr_loc(i)=0.0d0
2793       enddo
2794 c
2795 c
2796 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2797 C
2798 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2799 C
2800       do i=iturn3_start,iturn3_end
2801         if (itype(i).eq.21 .or. itype(i+1).eq.21
2802      &  .or. itype(i+2).eq.21 .or. itype(i+3).eq.21) cycle
2803         dxi=dc(1,i)
2804         dyi=dc(2,i)
2805         dzi=dc(3,i)
2806         dx_normi=dc_norm(1,i)
2807         dy_normi=dc_norm(2,i)
2808         dz_normi=dc_norm(3,i)
2809         xmedi=c(1,i)+0.5d0*dxi
2810         ymedi=c(2,i)+0.5d0*dyi
2811         zmedi=c(3,i)+0.5d0*dzi
2812         num_conti=0
2813         call eelecij(i,i+2,ees,evdw1,eel_loc)
2814         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2815         num_cont_hb(i)=num_conti
2816       enddo
2817       do i=iturn4_start,iturn4_end
2818         if (itype(i).eq.21 .or. itype(i+1).eq.21
2819      &    .or. itype(i+3).eq.21
2820      &    .or. itype(i+4).eq.21) cycle
2821         dxi=dc(1,i)
2822         dyi=dc(2,i)
2823         dzi=dc(3,i)
2824         dx_normi=dc_norm(1,i)
2825         dy_normi=dc_norm(2,i)
2826         dz_normi=dc_norm(3,i)
2827         xmedi=c(1,i)+0.5d0*dxi
2828         ymedi=c(2,i)+0.5d0*dyi
2829         zmedi=c(3,i)+0.5d0*dzi
2830         num_conti=num_cont_hb(i)
2831         call eelecij(i,i+3,ees,evdw1,eel_loc)
2832         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.21)
2833      &   call eturn4(i,eello_turn4)
2834         num_cont_hb(i)=num_conti
2835       enddo   ! i
2836 c
2837 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2838 c
2839       do i=iatel_s,iatel_e
2840         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
2841         dxi=dc(1,i)
2842         dyi=dc(2,i)
2843         dzi=dc(3,i)
2844         dx_normi=dc_norm(1,i)
2845         dy_normi=dc_norm(2,i)
2846         dz_normi=dc_norm(3,i)
2847         xmedi=c(1,i)+0.5d0*dxi
2848         ymedi=c(2,i)+0.5d0*dyi
2849         zmedi=c(3,i)+0.5d0*dzi
2850 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2851         num_conti=num_cont_hb(i)
2852         do j=ielstart(i),ielend(i)
2853 c          write (iout,*) i,j,itype(i),itype(j)
2854           if (itype(j).eq.21 .or. itype(j+1).eq.21) cycle
2855           call eelecij(i,j,ees,evdw1,eel_loc)
2856         enddo ! j
2857         num_cont_hb(i)=num_conti
2858       enddo   ! i
2859 c      write (iout,*) "Number of loop steps in EELEC:",ind
2860 cd      do i=1,nres
2861 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2862 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2863 cd      enddo
2864 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2865 ccc      eel_loc=eel_loc+eello_turn3
2866 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2867       return
2868       end
2869 C-------------------------------------------------------------------------------
2870       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2871       implicit real*8 (a-h,o-z)
2872       include 'DIMENSIONS'
2873 #ifdef MPI
2874       include "mpif.h"
2875 #endif
2876       include 'COMMON.CONTROL'
2877       include 'COMMON.IOUNITS'
2878       include 'COMMON.GEO'
2879       include 'COMMON.VAR'
2880       include 'COMMON.LOCAL'
2881       include 'COMMON.CHAIN'
2882       include 'COMMON.DERIV'
2883       include 'COMMON.INTERACT'
2884       include 'COMMON.CONTACTS'
2885       include 'COMMON.TORSION'
2886       include 'COMMON.VECTORS'
2887       include 'COMMON.FFIELD'
2888       include 'COMMON.TIME1'
2889       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2890      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2891       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2892      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2893       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2894      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2895      &    num_conti,j1,j2
2896 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2897 #ifdef MOMENT
2898       double precision scal_el /1.0d0/
2899 #else
2900       double precision scal_el /0.5d0/
2901 #endif
2902 C 12/13/98
2903 C 13-go grudnia roku pamietnego...
2904       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2905      &                   0.0d0,1.0d0,0.0d0,
2906      &                   0.0d0,0.0d0,1.0d0/
2907 c          time00=MPI_Wtime()
2908 cd      write (iout,*) "eelecij",i,j
2909 c          ind=ind+1
2910           iteli=itel(i)
2911           itelj=itel(j)
2912           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2913           aaa=app(iteli,itelj)
2914           bbb=bpp(iteli,itelj)
2915           ael6i=ael6(iteli,itelj)
2916           ael3i=ael3(iteli,itelj)
2917           dxj=dc(1,j)
2918           dyj=dc(2,j)
2919           dzj=dc(3,j)
2920           dx_normj=dc_norm(1,j)
2921           dy_normj=dc_norm(2,j)
2922           dz_normj=dc_norm(3,j)
2923           xj=c(1,j)+0.5D0*dxj-xmedi
2924           yj=c(2,j)+0.5D0*dyj-ymedi
2925           zj=c(3,j)+0.5D0*dzj-zmedi
2926           rij=xj*xj+yj*yj+zj*zj
2927           rrmij=1.0D0/rij
2928           rij=dsqrt(rij)
2929           rmij=1.0D0/rij
2930           r3ij=rrmij*rmij
2931           r6ij=r3ij*r3ij
2932           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2933           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2934           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2935           fac=cosa-3.0D0*cosb*cosg
2936           ev1=aaa*r6ij*r6ij
2937 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2938           if (j.eq.i+2) ev1=scal_el*ev1
2939           ev2=bbb*r6ij
2940           fac3=ael6i*r6ij
2941           fac4=ael3i*r3ij
2942           evdwij=ev1+ev2
2943           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2944           el2=fac4*fac
2945           eesij=el1+el2
2946 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2947           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2948           ees=ees+eesij
2949           evdw1=evdw1+evdwij
2950 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2951 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2952 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2953 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2954
2955           if (energy_dec) then
2956               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2957               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2958           endif
2959
2960 C
2961 C Calculate contributions to the Cartesian gradient.
2962 C
2963 #ifdef SPLITELE
2964           facvdw=-6*rrmij*(ev1+evdwij)
2965           facel=-3*rrmij*(el1+eesij)
2966           fac1=fac
2967           erij(1)=xj*rmij
2968           erij(2)=yj*rmij
2969           erij(3)=zj*rmij
2970 *
2971 * Radial derivatives. First process both termini of the fragment (i,j)
2972 *
2973           ggg(1)=facel*xj
2974           ggg(2)=facel*yj
2975           ggg(3)=facel*zj
2976 c          do k=1,3
2977 c            ghalf=0.5D0*ggg(k)
2978 c            gelc(k,i)=gelc(k,i)+ghalf
2979 c            gelc(k,j)=gelc(k,j)+ghalf
2980 c          enddo
2981 c 9/28/08 AL Gradient compotents will be summed only at the end
2982           do k=1,3
2983             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2984             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2985           enddo
2986 *
2987 * Loop over residues i+1 thru j-1.
2988 *
2989 cgrad          do k=i+1,j-1
2990 cgrad            do l=1,3
2991 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2992 cgrad            enddo
2993 cgrad          enddo
2994           ggg(1)=facvdw*xj
2995           ggg(2)=facvdw*yj
2996           ggg(3)=facvdw*zj
2997 c          do k=1,3
2998 c            ghalf=0.5D0*ggg(k)
2999 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3000 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3001 c          enddo
3002 c 9/28/08 AL Gradient compotents will be summed only at the end
3003           do k=1,3
3004             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3005             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3006           enddo
3007 *
3008 * Loop over residues i+1 thru j-1.
3009 *
3010 cgrad          do k=i+1,j-1
3011 cgrad            do l=1,3
3012 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3013 cgrad            enddo
3014 cgrad          enddo
3015 #else
3016           facvdw=ev1+evdwij
3017           facel=el1+eesij
3018           fac1=fac
3019           fac=-3*rrmij*(facvdw+facvdw+facel)
3020           erij(1)=xj*rmij
3021           erij(2)=yj*rmij
3022           erij(3)=zj*rmij
3023 *
3024 * Radial derivatives. First process both termini of the fragment (i,j)
3025 *
3026           ggg(1)=fac*xj
3027           ggg(2)=fac*yj
3028           ggg(3)=fac*zj
3029 c          do k=1,3
3030 c            ghalf=0.5D0*ggg(k)
3031 c            gelc(k,i)=gelc(k,i)+ghalf
3032 c            gelc(k,j)=gelc(k,j)+ghalf
3033 c          enddo
3034 c 9/28/08 AL Gradient compotents will be summed only at the end
3035           do k=1,3
3036             gelc_long(k,j)=gelc(k,j)+ggg(k)
3037             gelc_long(k,i)=gelc(k,i)-ggg(k)
3038           enddo
3039 *
3040 * Loop over residues i+1 thru j-1.
3041 *
3042 cgrad          do k=i+1,j-1
3043 cgrad            do l=1,3
3044 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3045 cgrad            enddo
3046 cgrad          enddo
3047 c 9/28/08 AL Gradient compotents will be summed only at the end
3048           ggg(1)=facvdw*xj
3049           ggg(2)=facvdw*yj
3050           ggg(3)=facvdw*zj
3051           do k=1,3
3052             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3053             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3054           enddo
3055 #endif
3056 *
3057 * Angular part
3058 *
3059           ecosa=2.0D0*fac3*fac1+fac4
3060           fac4=-3.0D0*fac4
3061           fac3=-6.0D0*fac3
3062           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3063           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3064           do k=1,3
3065             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3066             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3067           enddo
3068 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3069 cd   &          (dcosg(k),k=1,3)
3070           do k=1,3
3071             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3072           enddo
3073 c          do k=1,3
3074 c            ghalf=0.5D0*ggg(k)
3075 c            gelc(k,i)=gelc(k,i)+ghalf
3076 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3077 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3078 c            gelc(k,j)=gelc(k,j)+ghalf
3079 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3080 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3081 c          enddo
3082 cgrad          do k=i+1,j-1
3083 cgrad            do l=1,3
3084 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3085 cgrad            enddo
3086 cgrad          enddo
3087           do k=1,3
3088             gelc(k,i)=gelc(k,i)
3089      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3090      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3091             gelc(k,j)=gelc(k,j)
3092      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3093      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3094             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3095             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3096           enddo
3097           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3098      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3099      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3100 C
3101 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3102 C   energy of a peptide unit is assumed in the form of a second-order
3103 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3104 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3105 C   are computed for EVERY pair of non-contiguous peptide groups.
3106 C
3107           if (j.lt.nres-1) then
3108             j1=j+1
3109             j2=j-1
3110           else
3111             j1=j-1
3112             j2=j-2
3113           endif
3114           kkk=0
3115           do k=1,2
3116             do l=1,2
3117               kkk=kkk+1
3118               muij(kkk)=mu(k,i)*mu(l,j)
3119             enddo
3120           enddo
3121 cd         write (iout,*) 'EELEC: i',i,' j',j
3122 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3123 cd          write(iout,*) 'muij',muij
3124           ury=scalar(uy(1,i),erij)
3125           urz=scalar(uz(1,i),erij)
3126           vry=scalar(uy(1,j),erij)
3127           vrz=scalar(uz(1,j),erij)
3128           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3129           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3130           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3131           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3132           fac=dsqrt(-ael6i)*r3ij
3133           a22=a22*fac
3134           a23=a23*fac
3135           a32=a32*fac
3136           a33=a33*fac
3137 cd          write (iout,'(4i5,4f10.5)')
3138 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3139 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3140 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3141 cd     &      uy(:,j),uz(:,j)
3142 cd          write (iout,'(4f10.5)')
3143 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3144 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3145 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3146 cd           write (iout,'(9f10.5/)')
3147 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3148 C Derivatives of the elements of A in virtual-bond vectors
3149           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3150           do k=1,3
3151             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3152             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3153             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3154             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3155             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3156             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3157             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3158             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3159             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3160             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3161             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3162             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3163           enddo
3164 C Compute radial contributions to the gradient
3165           facr=-3.0d0*rrmij
3166           a22der=a22*facr
3167           a23der=a23*facr
3168           a32der=a32*facr
3169           a33der=a33*facr
3170           agg(1,1)=a22der*xj
3171           agg(2,1)=a22der*yj
3172           agg(3,1)=a22der*zj
3173           agg(1,2)=a23der*xj
3174           agg(2,2)=a23der*yj
3175           agg(3,2)=a23der*zj
3176           agg(1,3)=a32der*xj
3177           agg(2,3)=a32der*yj
3178           agg(3,3)=a32der*zj
3179           agg(1,4)=a33der*xj
3180           agg(2,4)=a33der*yj
3181           agg(3,4)=a33der*zj
3182 C Add the contributions coming from er
3183           fac3=-3.0d0*fac
3184           do k=1,3
3185             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3186             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3187             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3188             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3189           enddo
3190           do k=1,3
3191 C Derivatives in DC(i)
3192 cgrad            ghalf1=0.5d0*agg(k,1)
3193 cgrad            ghalf2=0.5d0*agg(k,2)
3194 cgrad            ghalf3=0.5d0*agg(k,3)
3195 cgrad            ghalf4=0.5d0*agg(k,4)
3196             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3197      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3198             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3199      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3200             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3201      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3202             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3203      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3204 C Derivatives in DC(i+1)
3205             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3206      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3207             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3208      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3209             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3210      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3211             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3212      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3213 C Derivatives in DC(j)
3214             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3215      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3216             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3217      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3218             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3219      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3220             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3221      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3222 C Derivatives in DC(j+1) or DC(nres-1)
3223             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3224      &      -3.0d0*vryg(k,3)*ury)
3225             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3226      &      -3.0d0*vrzg(k,3)*ury)
3227             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3228      &      -3.0d0*vryg(k,3)*urz)
3229             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3230      &      -3.0d0*vrzg(k,3)*urz)
3231 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3232 cgrad              do l=1,4
3233 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3234 cgrad              enddo
3235 cgrad            endif
3236           enddo
3237           acipa(1,1)=a22
3238           acipa(1,2)=a23
3239           acipa(2,1)=a32
3240           acipa(2,2)=a33
3241           a22=-a22
3242           a23=-a23
3243           do l=1,2
3244             do k=1,3
3245               agg(k,l)=-agg(k,l)
3246               aggi(k,l)=-aggi(k,l)
3247               aggi1(k,l)=-aggi1(k,l)
3248               aggj(k,l)=-aggj(k,l)
3249               aggj1(k,l)=-aggj1(k,l)
3250             enddo
3251           enddo
3252           if (j.lt.nres-1) then
3253             a22=-a22
3254             a32=-a32
3255             do l=1,3,2
3256               do k=1,3
3257                 agg(k,l)=-agg(k,l)
3258                 aggi(k,l)=-aggi(k,l)
3259                 aggi1(k,l)=-aggi1(k,l)
3260                 aggj(k,l)=-aggj(k,l)
3261                 aggj1(k,l)=-aggj1(k,l)
3262               enddo
3263             enddo
3264           else
3265             a22=-a22
3266             a23=-a23
3267             a32=-a32
3268             a33=-a33
3269             do l=1,4
3270               do k=1,3
3271                 agg(k,l)=-agg(k,l)
3272                 aggi(k,l)=-aggi(k,l)
3273                 aggi1(k,l)=-aggi1(k,l)
3274                 aggj(k,l)=-aggj(k,l)
3275                 aggj1(k,l)=-aggj1(k,l)
3276               enddo
3277             enddo
3278           endif
3279           ENDIF ! WCORR
3280           IF (wel_loc.gt.0.0d0) THEN
3281 C Contribution to the local-electrostatic energy coming from the i-j pair
3282           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3283      &     +a33*muij(4)
3284 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3285
3286           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3287      &            'eelloc',i,j,eel_loc_ij
3288
3289           eel_loc=eel_loc+eel_loc_ij
3290 C Partial derivatives in virtual-bond dihedral angles gamma
3291           if (i.gt.1)
3292      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3293      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3294      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3295           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3296      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3297      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3298 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3299           do l=1,3
3300             ggg(l)=agg(l,1)*muij(1)+
3301      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3302             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3303             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3304 cgrad            ghalf=0.5d0*ggg(l)
3305 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3306 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3307           enddo
3308 cgrad          do k=i+1,j2
3309 cgrad            do l=1,3
3310 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3311 cgrad            enddo
3312 cgrad          enddo
3313 C Remaining derivatives of eello
3314           do l=1,3
3315             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3316      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3317             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3318      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3319             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3320      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3321             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3322      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3323           enddo
3324           ENDIF
3325 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3326 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3327           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3328      &       .and. num_conti.le.maxconts) then
3329 c            write (iout,*) i,j," entered corr"
3330 C
3331 C Calculate the contact function. The ith column of the array JCONT will
3332 C contain the numbers of atoms that make contacts with the atom I (of numbers
3333 C greater than I). The arrays FACONT and GACONT will contain the values of
3334 C the contact function and its derivative.
3335 c           r0ij=1.02D0*rpp(iteli,itelj)
3336 c           r0ij=1.11D0*rpp(iteli,itelj)
3337             r0ij=2.20D0*rpp(iteli,itelj)
3338 c           r0ij=1.55D0*rpp(iteli,itelj)
3339             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3340             if (fcont.gt.0.0D0) then
3341               num_conti=num_conti+1
3342               if (num_conti.gt.maxconts) then
3343                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3344      &                         ' will skip next contacts for this conf.'
3345               else
3346                 jcont_hb(num_conti,i)=j
3347 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3348 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3349                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3350      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3351 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3352 C  terms.
3353                 d_cont(num_conti,i)=rij
3354 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3355 C     --- Electrostatic-interaction matrix ---
3356                 a_chuj(1,1,num_conti,i)=a22
3357                 a_chuj(1,2,num_conti,i)=a23
3358                 a_chuj(2,1,num_conti,i)=a32
3359                 a_chuj(2,2,num_conti,i)=a33
3360 C     --- Gradient of rij
3361                 do kkk=1,3
3362                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3363                 enddo
3364                 kkll=0
3365                 do k=1,2
3366                   do l=1,2
3367                     kkll=kkll+1
3368                     do m=1,3
3369                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3370                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3371                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3372                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3373                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3374                     enddo
3375                   enddo
3376                 enddo
3377                 ENDIF
3378                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3379 C Calculate contact energies
3380                 cosa4=4.0D0*cosa
3381                 wij=cosa-3.0D0*cosb*cosg
3382                 cosbg1=cosb+cosg
3383                 cosbg2=cosb-cosg
3384 c               fac3=dsqrt(-ael6i)/r0ij**3
3385                 fac3=dsqrt(-ael6i)*r3ij
3386 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3387                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3388                 if (ees0tmp.gt.0) then
3389                   ees0pij=dsqrt(ees0tmp)
3390                 else
3391                   ees0pij=0
3392                 endif
3393 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3394                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3395                 if (ees0tmp.gt.0) then
3396                   ees0mij=dsqrt(ees0tmp)
3397                 else
3398                   ees0mij=0
3399                 endif
3400 c               ees0mij=0.0D0
3401                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3402                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3403 C Diagnostics. Comment out or remove after debugging!
3404 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3405 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3406 c               ees0m(num_conti,i)=0.0D0
3407 C End diagnostics.
3408 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3409 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3410 C Angular derivatives of the contact function
3411                 ees0pij1=fac3/ees0pij
3412                 ees0mij1=fac3/ees0mij
3413                 fac3p=-3.0D0*fac3*rrmij
3414                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3415                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3416 c               ees0mij1=0.0D0
3417                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3418                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3419                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3420                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3421                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3422                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3423                 ecosap=ecosa1+ecosa2
3424                 ecosbp=ecosb1+ecosb2
3425                 ecosgp=ecosg1+ecosg2
3426                 ecosam=ecosa1-ecosa2
3427                 ecosbm=ecosb1-ecosb2
3428                 ecosgm=ecosg1-ecosg2
3429 C Diagnostics
3430 c               ecosap=ecosa1
3431 c               ecosbp=ecosb1
3432 c               ecosgp=ecosg1
3433 c               ecosam=0.0D0
3434 c               ecosbm=0.0D0
3435 c               ecosgm=0.0D0
3436 C End diagnostics
3437                 facont_hb(num_conti,i)=fcont
3438                 fprimcont=fprimcont/rij
3439 cd              facont_hb(num_conti,i)=1.0D0
3440 C Following line is for diagnostics.
3441 cd              fprimcont=0.0D0
3442                 do k=1,3
3443                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3444                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3445                 enddo
3446                 do k=1,3
3447                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3448                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3449                 enddo
3450                 gggp(1)=gggp(1)+ees0pijp*xj
3451                 gggp(2)=gggp(2)+ees0pijp*yj
3452                 gggp(3)=gggp(3)+ees0pijp*zj
3453                 gggm(1)=gggm(1)+ees0mijp*xj
3454                 gggm(2)=gggm(2)+ees0mijp*yj
3455                 gggm(3)=gggm(3)+ees0mijp*zj
3456 C Derivatives due to the contact function
3457                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3458                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3459                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3460                 do k=1,3
3461 c
3462 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3463 c          following the change of gradient-summation algorithm.
3464 c
3465 cgrad                  ghalfp=0.5D0*gggp(k)
3466 cgrad                  ghalfm=0.5D0*gggm(k)
3467                   gacontp_hb1(k,num_conti,i)=!ghalfp
3468      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3469      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3470                   gacontp_hb2(k,num_conti,i)=!ghalfp
3471      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3472      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3473                   gacontp_hb3(k,num_conti,i)=gggp(k)
3474                   gacontm_hb1(k,num_conti,i)=!ghalfm
3475      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3476      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3477                   gacontm_hb2(k,num_conti,i)=!ghalfm
3478      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3479      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3480                   gacontm_hb3(k,num_conti,i)=gggm(k)
3481                 enddo
3482 C Diagnostics. Comment out or remove after debugging!
3483 cdiag           do k=1,3
3484 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3485 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3486 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3487 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3488 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3489 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3490 cdiag           enddo
3491               ENDIF ! wcorr
3492               endif  ! num_conti.le.maxconts
3493             endif  ! fcont.gt.0
3494           endif    ! j.gt.i+1
3495           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3496             do k=1,4
3497               do l=1,3
3498                 ghalf=0.5d0*agg(l,k)
3499                 aggi(l,k)=aggi(l,k)+ghalf
3500                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3501                 aggj(l,k)=aggj(l,k)+ghalf
3502               enddo
3503             enddo
3504             if (j.eq.nres-1 .and. i.lt.j-2) then
3505               do k=1,4
3506                 do l=1,3
3507                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3508                 enddo
3509               enddo
3510             endif
3511           endif
3512 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3513       return
3514       end
3515 C-----------------------------------------------------------------------------
3516       subroutine eturn3(i,eello_turn3)
3517 C Third- and fourth-order contributions from turns
3518       implicit real*8 (a-h,o-z)
3519       include 'DIMENSIONS'
3520       include 'COMMON.IOUNITS'
3521       include 'COMMON.GEO'
3522       include 'COMMON.VAR'
3523       include 'COMMON.LOCAL'
3524       include 'COMMON.CHAIN'
3525       include 'COMMON.DERIV'
3526       include 'COMMON.INTERACT'
3527       include 'COMMON.CONTACTS'
3528       include 'COMMON.TORSION'
3529       include 'COMMON.VECTORS'
3530       include 'COMMON.FFIELD'
3531       include 'COMMON.CONTROL'
3532       dimension ggg(3)
3533       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3534      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3535      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3536       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3537      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3538       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3539      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3540      &    num_conti,j1,j2
3541       j=i+2
3542 c      write (iout,*) "eturn3",i,j,j1,j2
3543       a_temp(1,1)=a22
3544       a_temp(1,2)=a23
3545       a_temp(2,1)=a32
3546       a_temp(2,2)=a33
3547 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3548 C
3549 C               Third-order contributions
3550 C
3551 C                 (i+2)o----(i+3)
3552 C                      | |
3553 C                      | |
3554 C                 (i+1)o----i
3555 C
3556 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3557 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3558         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3559         call transpose2(auxmat(1,1),auxmat1(1,1))
3560         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3561         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3562         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3563      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3564 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3565 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3566 cd     &    ' eello_turn3_num',4*eello_turn3_num
3567 C Derivatives in gamma(i)
3568         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3569         call transpose2(auxmat2(1,1),auxmat3(1,1))
3570         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3571         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3572 C Derivatives in gamma(i+1)
3573         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3574         call transpose2(auxmat2(1,1),auxmat3(1,1))
3575         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3576         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3577      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3578 C Cartesian derivatives
3579         do l=1,3
3580 c            ghalf1=0.5d0*agg(l,1)
3581 c            ghalf2=0.5d0*agg(l,2)
3582 c            ghalf3=0.5d0*agg(l,3)
3583 c            ghalf4=0.5d0*agg(l,4)
3584           a_temp(1,1)=aggi(l,1)!+ghalf1
3585           a_temp(1,2)=aggi(l,2)!+ghalf2
3586           a_temp(2,1)=aggi(l,3)!+ghalf3
3587           a_temp(2,2)=aggi(l,4)!+ghalf4
3588           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3589           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3590      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3591           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3592           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3593           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3594           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3595           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3596           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3597      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3598           a_temp(1,1)=aggj(l,1)!+ghalf1
3599           a_temp(1,2)=aggj(l,2)!+ghalf2
3600           a_temp(2,1)=aggj(l,3)!+ghalf3
3601           a_temp(2,2)=aggj(l,4)!+ghalf4
3602           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3603           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3604      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3605           a_temp(1,1)=aggj1(l,1)
3606           a_temp(1,2)=aggj1(l,2)
3607           a_temp(2,1)=aggj1(l,3)
3608           a_temp(2,2)=aggj1(l,4)
3609           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3610           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3611      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3612         enddo
3613       return
3614       end
3615 C-------------------------------------------------------------------------------
3616       subroutine eturn4(i,eello_turn4)
3617 C Third- and fourth-order contributions from turns
3618       implicit real*8 (a-h,o-z)
3619       include 'DIMENSIONS'
3620       include 'COMMON.IOUNITS'
3621       include 'COMMON.GEO'
3622       include 'COMMON.VAR'
3623       include 'COMMON.LOCAL'
3624       include 'COMMON.CHAIN'
3625       include 'COMMON.DERIV'
3626       include 'COMMON.INTERACT'
3627       include 'COMMON.CONTACTS'
3628       include 'COMMON.TORSION'
3629       include 'COMMON.VECTORS'
3630       include 'COMMON.FFIELD'
3631       include 'COMMON.CONTROL'
3632       dimension ggg(3)
3633       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3634      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3635      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3636       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3637      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3638       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3639      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3640      &    num_conti,j1,j2
3641       j=i+3
3642 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3643 C
3644 C               Fourth-order contributions
3645 C
3646 C                 (i+3)o----(i+4)
3647 C                     /  |
3648 C               (i+2)o   |
3649 C                     \  |
3650 C                 (i+1)o----i
3651 C
3652 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3653 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3654 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3655         a_temp(1,1)=a22
3656         a_temp(1,2)=a23
3657         a_temp(2,1)=a32
3658         a_temp(2,2)=a33
3659         iti1=itortyp(itype(i+1))
3660         iti2=itortyp(itype(i+2))
3661         iti3=itortyp(itype(i+3))
3662 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3663         call transpose2(EUg(1,1,i+1),e1t(1,1))
3664         call transpose2(Eug(1,1,i+2),e2t(1,1))
3665         call transpose2(Eug(1,1,i+3),e3t(1,1))
3666         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3667         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3668         s1=scalar2(b1(1,iti2),auxvec(1))
3669         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3670         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3671         s2=scalar2(b1(1,iti1),auxvec(1))
3672         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3673         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3674         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3675         eello_turn4=eello_turn4-(s1+s2+s3)
3676         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3677      &      'eturn4',i,j,-(s1+s2+s3)
3678 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3679 cd     &    ' eello_turn4_num',8*eello_turn4_num
3680 C Derivatives in gamma(i)
3681         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3682         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3683         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3684         s1=scalar2(b1(1,iti2),auxvec(1))
3685         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3686         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3687         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3688 C Derivatives in gamma(i+1)
3689         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3690         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3691         s2=scalar2(b1(1,iti1),auxvec(1))
3692         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3693         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3694         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3695         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3696 C Derivatives in gamma(i+2)
3697         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3698         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3699         s1=scalar2(b1(1,iti2),auxvec(1))
3700         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3701         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3702         s2=scalar2(b1(1,iti1),auxvec(1))
3703         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3704         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3705         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3706         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3707 C Cartesian derivatives
3708 C Derivatives of this turn contributions in DC(i+2)
3709         if (j.lt.nres-1) then
3710           do l=1,3
3711             a_temp(1,1)=agg(l,1)
3712             a_temp(1,2)=agg(l,2)
3713             a_temp(2,1)=agg(l,3)
3714             a_temp(2,2)=agg(l,4)
3715             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3716             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3717             s1=scalar2(b1(1,iti2),auxvec(1))
3718             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3719             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3720             s2=scalar2(b1(1,iti1),auxvec(1))
3721             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3722             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3723             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3724             ggg(l)=-(s1+s2+s3)
3725             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3726           enddo
3727         endif
3728 C Remaining derivatives of this turn contribution
3729         do l=1,3
3730           a_temp(1,1)=aggi(l,1)
3731           a_temp(1,2)=aggi(l,2)
3732           a_temp(2,1)=aggi(l,3)
3733           a_temp(2,2)=aggi(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           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3744           a_temp(1,1)=aggi1(l,1)
3745           a_temp(1,2)=aggi1(l,2)
3746           a_temp(2,1)=aggi1(l,3)
3747           a_temp(2,2)=aggi1(l,4)
3748           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3749           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3750           s1=scalar2(b1(1,iti2),auxvec(1))
3751           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3752           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3753           s2=scalar2(b1(1,iti1),auxvec(1))
3754           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3755           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3756           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3757           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3758           a_temp(1,1)=aggj(l,1)
3759           a_temp(1,2)=aggj(l,2)
3760           a_temp(2,1)=aggj(l,3)
3761           a_temp(2,2)=aggj(l,4)
3762           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3763           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3764           s1=scalar2(b1(1,iti2),auxvec(1))
3765           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3766           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3767           s2=scalar2(b1(1,iti1),auxvec(1))
3768           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3769           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3770           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3771           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3772           a_temp(1,1)=aggj1(l,1)
3773           a_temp(1,2)=aggj1(l,2)
3774           a_temp(2,1)=aggj1(l,3)
3775           a_temp(2,2)=aggj1(l,4)
3776           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3777           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3778           s1=scalar2(b1(1,iti2),auxvec(1))
3779           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3780           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3781           s2=scalar2(b1(1,iti1),auxvec(1))
3782           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3783           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3784           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3785 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3786           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3787         enddo
3788       return
3789       end
3790 C-----------------------------------------------------------------------------
3791       subroutine vecpr(u,v,w)
3792       implicit real*8(a-h,o-z)
3793       dimension u(3),v(3),w(3)
3794       w(1)=u(2)*v(3)-u(3)*v(2)
3795       w(2)=-u(1)*v(3)+u(3)*v(1)
3796       w(3)=u(1)*v(2)-u(2)*v(1)
3797       return
3798       end
3799 C-----------------------------------------------------------------------------
3800       subroutine unormderiv(u,ugrad,unorm,ungrad)
3801 C This subroutine computes the derivatives of a normalized vector u, given
3802 C the derivatives computed without normalization conditions, ugrad. Returns
3803 C ungrad.
3804       implicit none
3805       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3806       double precision vec(3)
3807       double precision scalar
3808       integer i,j
3809 c      write (2,*) 'ugrad',ugrad
3810 c      write (2,*) 'u',u
3811       do i=1,3
3812         vec(i)=scalar(ugrad(1,i),u(1))
3813       enddo
3814 c      write (2,*) 'vec',vec
3815       do i=1,3
3816         do j=1,3
3817           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3818         enddo
3819       enddo
3820 c      write (2,*) 'ungrad',ungrad
3821       return
3822       end
3823 C-----------------------------------------------------------------------------
3824       subroutine escp_soft_sphere(evdw2,evdw2_14)
3825 C
3826 C This subroutine calculates the excluded-volume interaction energy between
3827 C peptide-group centers and side chains and its gradient in virtual-bond and
3828 C side-chain vectors.
3829 C
3830       implicit real*8 (a-h,o-z)
3831       include 'DIMENSIONS'
3832       include 'COMMON.GEO'
3833       include 'COMMON.VAR'
3834       include 'COMMON.LOCAL'
3835       include 'COMMON.CHAIN'
3836       include 'COMMON.DERIV'
3837       include 'COMMON.INTERACT'
3838       include 'COMMON.FFIELD'
3839       include 'COMMON.IOUNITS'
3840       include 'COMMON.CONTROL'
3841       dimension ggg(3)
3842       evdw2=0.0D0
3843       evdw2_14=0.0d0
3844       r0_scp=4.5d0
3845 cd    print '(a)','Enter ESCP'
3846 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3847       do i=iatscp_s,iatscp_e
3848         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3849         iteli=itel(i)
3850         xi=0.5D0*(c(1,i)+c(1,i+1))
3851         yi=0.5D0*(c(2,i)+c(2,i+1))
3852         zi=0.5D0*(c(3,i)+c(3,i+1))
3853
3854         do iint=1,nscp_gr(i)
3855
3856         do j=iscpstart(i,iint),iscpend(i,iint)
3857           if (itype(j).eq.21) cycle
3858           itypj=itype(j)
3859 C Uncomment following three lines for SC-p interactions
3860 c         xj=c(1,nres+j)-xi
3861 c         yj=c(2,nres+j)-yi
3862 c         zj=c(3,nres+j)-zi
3863 C Uncomment following three lines for Ca-p interactions
3864           xj=c(1,j)-xi
3865           yj=c(2,j)-yi
3866           zj=c(3,j)-zi
3867           rij=xj*xj+yj*yj+zj*zj
3868           r0ij=r0_scp
3869           r0ijsq=r0ij*r0ij
3870           if (rij.lt.r0ijsq) then
3871             evdwij=0.25d0*(rij-r0ijsq)**2
3872             fac=rij-r0ijsq
3873           else
3874             evdwij=0.0d0
3875             fac=0.0d0
3876           endif
3877           evdw2=evdw2+evdwij
3878 C
3879 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3880 C
3881           ggg(1)=xj*fac
3882           ggg(2)=yj*fac
3883           ggg(3)=zj*fac
3884 cgrad          if (j.lt.i) then
3885 cd          write (iout,*) 'j<i'
3886 C Uncomment following three lines for SC-p interactions
3887 c           do k=1,3
3888 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3889 c           enddo
3890 cgrad          else
3891 cd          write (iout,*) 'j>i'
3892 cgrad            do k=1,3
3893 cgrad              ggg(k)=-ggg(k)
3894 C Uncomment following line for SC-p interactions
3895 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3896 cgrad            enddo
3897 cgrad          endif
3898 cgrad          do k=1,3
3899 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3900 cgrad          enddo
3901 cgrad          kstart=min0(i+1,j)
3902 cgrad          kend=max0(i-1,j-1)
3903 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3904 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3905 cgrad          do k=kstart,kend
3906 cgrad            do l=1,3
3907 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3908 cgrad            enddo
3909 cgrad          enddo
3910           do k=1,3
3911             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3912             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3913           enddo
3914         enddo
3915
3916         enddo ! iint
3917       enddo ! i
3918       return
3919       end
3920 C-----------------------------------------------------------------------------
3921       subroutine escp(evdw2,evdw2_14)
3922 C
3923 C This subroutine calculates the excluded-volume interaction energy between
3924 C peptide-group centers and side chains and its gradient in virtual-bond and
3925 C side-chain vectors.
3926 C
3927       implicit real*8 (a-h,o-z)
3928       include 'DIMENSIONS'
3929       include 'COMMON.GEO'
3930       include 'COMMON.VAR'
3931       include 'COMMON.LOCAL'
3932       include 'COMMON.CHAIN'
3933       include 'COMMON.DERIV'
3934       include 'COMMON.INTERACT'
3935       include 'COMMON.FFIELD'
3936       include 'COMMON.IOUNITS'
3937       include 'COMMON.CONTROL'
3938       dimension ggg(3)
3939       evdw2=0.0D0
3940       evdw2_14=0.0d0
3941 cd    print '(a)','Enter ESCP'
3942 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3943       do i=iatscp_s,iatscp_e
3944         if (itype(i).eq.21 .or. itype(i+1).eq.21) cycle
3945         iteli=itel(i)
3946         xi=0.5D0*(c(1,i)+c(1,i+1))
3947         yi=0.5D0*(c(2,i)+c(2,i+1))
3948         zi=0.5D0*(c(3,i)+c(3,i+1))
3949
3950         do iint=1,nscp_gr(i)
3951
3952         do j=iscpstart(i,iint),iscpend(i,iint)
3953           itypj=itype(j)
3954           if (itypj.eq.21) cycle
3955 C Uncomment following three lines for SC-p interactions
3956 c         xj=c(1,nres+j)-xi
3957 c         yj=c(2,nres+j)-yi
3958 c         zj=c(3,nres+j)-zi
3959 C Uncomment following three lines for Ca-p interactions
3960           xj=c(1,j)-xi
3961           yj=c(2,j)-yi
3962           zj=c(3,j)-zi
3963           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3964           fac=rrij**expon2
3965           e1=fac*fac*aad(itypj,iteli)
3966           e2=fac*bad(itypj,iteli)
3967           if (iabs(j-i) .le. 2) then
3968             e1=scal14*e1
3969             e2=scal14*e2
3970             evdw2_14=evdw2_14+e1+e2
3971           endif
3972           evdwij=e1+e2
3973           evdw2=evdw2+evdwij
3974           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3975      &        'evdw2',i,j,evdwij
3976 C
3977 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3978 C
3979           fac=-(evdwij+e1)*rrij
3980           ggg(1)=xj*fac
3981           ggg(2)=yj*fac
3982           ggg(3)=zj*fac
3983 cgrad          if (j.lt.i) then
3984 cd          write (iout,*) 'j<i'
3985 C Uncomment following three lines for SC-p interactions
3986 c           do k=1,3
3987 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3988 c           enddo
3989 cgrad          else
3990 cd          write (iout,*) 'j>i'
3991 cgrad            do k=1,3
3992 cgrad              ggg(k)=-ggg(k)
3993 C Uncomment following line for SC-p interactions
3994 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3995 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3996 cgrad            enddo
3997 cgrad          endif
3998 cgrad          do k=1,3
3999 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4000 cgrad          enddo
4001 cgrad          kstart=min0(i+1,j)
4002 cgrad          kend=max0(i-1,j-1)
4003 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4004 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4005 cgrad          do k=kstart,kend
4006 cgrad            do l=1,3
4007 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4008 cgrad            enddo
4009 cgrad          enddo
4010           do k=1,3
4011             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4012             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4013           enddo
4014         enddo
4015
4016         enddo ! iint
4017       enddo ! i
4018       do i=1,nct
4019         do j=1,3
4020           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4021           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4022           gradx_scp(j,i)=expon*gradx_scp(j,i)
4023         enddo
4024       enddo
4025 C******************************************************************************
4026 C
4027 C                              N O T E !!!
4028 C
4029 C To save time the factor EXPON has been extracted from ALL components
4030 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4031 C use!
4032 C
4033 C******************************************************************************
4034       return
4035       end
4036 C--------------------------------------------------------------------------
4037       subroutine edis(ehpb)
4038 C
4039 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4040 C
4041       implicit real*8 (a-h,o-z)
4042       include 'DIMENSIONS'
4043       include 'COMMON.SBRIDGE'
4044       include 'COMMON.CHAIN'
4045       include 'COMMON.DERIV'
4046       include 'COMMON.VAR'
4047       include 'COMMON.INTERACT'
4048       include 'COMMON.IOUNITS'
4049       dimension ggg(3)
4050       ehpb=0.0D0
4051 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4052 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4053       if (link_end.eq.0) return
4054       do i=link_start,link_end
4055 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4056 C CA-CA distance used in regularization of structure.
4057         ii=ihpb(i)
4058         jj=jhpb(i)
4059 C iii and jjj point to the residues for which the distance is assigned.
4060         if (ii.gt.nres) then
4061           iii=ii-nres
4062           jjj=jj-nres
4063         else
4064           iii=ii
4065           jjj=jj
4066         endif
4067 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4068 c     &    dhpb(i),dhpb1(i),forcon(i)
4069 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4070 C    distance and angle dependent SS bond potential.
4071 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4072 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4073         if (.not.dyn_ss .and. i.le.nss) then
4074 C 15/02/13 CC dynamic SSbond - additional check
4075          if (ii.gt.nres
4076      &       .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4077           call ssbond_ene(iii,jjj,eij)
4078           ehpb=ehpb+2*eij
4079          endif
4080 cd          write (iout,*) "eij",eij
4081         else
4082 C Calculate the distance between the two points and its difference from the
4083 C target distance.
4084           dd=dist(ii,jj)
4085             rdis=dd-dhpb(i)
4086 C Get the force constant corresponding to this distance.
4087             waga=forcon(i)
4088 C Calculate the contribution to energy.
4089             ehpb=ehpb+waga*rdis*rdis
4090 C
4091 C Evaluate gradient.
4092 C
4093             fac=waga*rdis/dd
4094 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
4095 cd   &   ' waga=',waga,' fac=',fac
4096             do j=1,3
4097               ggg(j)=fac*(c(j,jj)-c(j,ii))
4098             enddo
4099 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4100 C If this is a SC-SC distance, we need to calculate the contributions to the
4101 C Cartesian gradient in the SC vectors (ghpbx).
4102           if (iii.lt.ii) then
4103           do j=1,3
4104             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4105             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4106           enddo
4107           endif
4108 cgrad        do j=iii,jjj-1
4109 cgrad          do k=1,3
4110 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4111 cgrad          enddo
4112 cgrad        enddo
4113           do k=1,3
4114             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4115             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4116           enddo
4117         endif
4118       enddo
4119       ehpb=0.5D0*ehpb
4120       return
4121       end
4122 C--------------------------------------------------------------------------
4123       subroutine ssbond_ene(i,j,eij)
4124 C
4125 C Calculate the distance and angle dependent SS-bond potential energy
4126 C using a free-energy function derived based on RHF/6-31G** ab initio
4127 C calculations of diethyl disulfide.
4128 C
4129 C A. Liwo and U. Kozlowska, 11/24/03
4130 C
4131       implicit real*8 (a-h,o-z)
4132       include 'DIMENSIONS'
4133       include 'COMMON.SBRIDGE'
4134       include 'COMMON.CHAIN'
4135       include 'COMMON.DERIV'
4136       include 'COMMON.LOCAL'
4137       include 'COMMON.INTERACT'
4138       include 'COMMON.VAR'
4139       include 'COMMON.IOUNITS'
4140       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4141       itypi=itype(i)
4142       xi=c(1,nres+i)
4143       yi=c(2,nres+i)
4144       zi=c(3,nres+i)
4145       dxi=dc_norm(1,nres+i)
4146       dyi=dc_norm(2,nres+i)
4147       dzi=dc_norm(3,nres+i)
4148 c      dsci_inv=dsc_inv(itypi)
4149       dsci_inv=vbld_inv(nres+i)
4150       itypj=itype(j)
4151 c      dscj_inv=dsc_inv(itypj)
4152       dscj_inv=vbld_inv(nres+j)
4153       xj=c(1,nres+j)-xi
4154       yj=c(2,nres+j)-yi
4155       zj=c(3,nres+j)-zi
4156       dxj=dc_norm(1,nres+j)
4157       dyj=dc_norm(2,nres+j)
4158       dzj=dc_norm(3,nres+j)
4159       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4160       rij=dsqrt(rrij)
4161       erij(1)=xj*rij
4162       erij(2)=yj*rij
4163       erij(3)=zj*rij
4164       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4165       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4166       om12=dxi*dxj+dyi*dyj+dzi*dzj
4167       do k=1,3
4168         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4169         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4170       enddo
4171       rij=1.0d0/rij
4172       deltad=rij-d0cm
4173       deltat1=1.0d0-om1
4174       deltat2=1.0d0+om2
4175       deltat12=om2-om1+2.0d0
4176       cosphi=om12-om1*om2
4177       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4178      &  +akct*deltad*deltat12
4179      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4180 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4181 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4182 c     &  " deltat12",deltat12," eij",eij
4183       ed=2*akcm*deltad+akct*deltat12
4184       pom1=akct*deltad
4185       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4186       eom1=-2*akth*deltat1-pom1-om2*pom2
4187       eom2= 2*akth*deltat2+pom1-om1*pom2
4188       eom12=pom2
4189       do k=1,3
4190         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4191         ghpbx(k,i)=ghpbx(k,i)-ggk
4192      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4193      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4194         ghpbx(k,j)=ghpbx(k,j)+ggk
4195      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4196      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4197         ghpbc(k,i)=ghpbc(k,i)-ggk
4198         ghpbc(k,j)=ghpbc(k,j)+ggk
4199       enddo
4200 C
4201 C Calculate the components of the gradient in DC and X
4202 C
4203 cgrad      do k=i,j-1
4204 cgrad        do l=1,3
4205 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4206 cgrad        enddo
4207 cgrad      enddo
4208       return
4209       end
4210 C--------------------------------------------------------------------------
4211       subroutine ebond(estr)
4212 c
4213 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4214 c
4215       implicit real*8 (a-h,o-z)
4216       include 'DIMENSIONS'
4217       include 'COMMON.LOCAL'
4218       include 'COMMON.GEO'
4219       include 'COMMON.INTERACT'
4220       include 'COMMON.DERIV'
4221       include 'COMMON.VAR'
4222       include 'COMMON.CHAIN'
4223       include 'COMMON.IOUNITS'
4224       include 'COMMON.NAMES'
4225       include 'COMMON.FFIELD'
4226       include 'COMMON.CONTROL'
4227       include 'COMMON.SETUP'
4228       double precision u(3),ud(3)
4229       estr=0.0d0
4230       estr1=0.0d0
4231       do i=ibondp_start,ibondp_end
4232         if (itype(i-1).eq.21 .or. itype(i).eq.21) then
4233           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4234           do j=1,3
4235           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4236      &      *dc(j,i-1)/vbld(i)
4237           enddo
4238           if (energy_dec) write(iout,*)
4239      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4240         else
4241         diff = vbld(i)-vbldp0
4242         if (energy_dec) write (iout,*)
4243      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4244         estr=estr+diff*diff
4245         do j=1,3
4246           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4247         enddo
4248 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4249         endif
4250       enddo
4251       estr=0.5d0*AKP*estr+estr1
4252 c
4253 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4254 c
4255       do i=ibond_start,ibond_end
4256         iti=itype(i)
4257         if (iti.ne.10 .and. iti.ne.21) then
4258           nbi=nbondterm(iti)
4259           if (nbi.eq.1) then
4260             diff=vbld(i+nres)-vbldsc0(1,iti)
4261             if (energy_dec) write (iout,*)
4262      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4263      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4264             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4265             do j=1,3
4266               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4267             enddo
4268           else
4269             do j=1,nbi
4270               diff=vbld(i+nres)-vbldsc0(j,iti)
4271               ud(j)=aksc(j,iti)*diff
4272               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4273             enddo
4274             uprod=u(1)
4275             do j=2,nbi
4276               uprod=uprod*u(j)
4277             enddo
4278             usum=0.0d0
4279             usumsqder=0.0d0
4280             do j=1,nbi
4281               uprod1=1.0d0
4282               uprod2=1.0d0
4283               do k=1,nbi
4284                 if (k.ne.j) then
4285                   uprod1=uprod1*u(k)
4286                   uprod2=uprod2*u(k)*u(k)
4287                 endif
4288               enddo
4289               usum=usum+uprod1
4290               usumsqder=usumsqder+ud(j)*uprod2
4291             enddo
4292             estr=estr+uprod/usum
4293             do j=1,3
4294              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4295             enddo
4296           endif
4297         endif
4298       enddo
4299       return
4300       end
4301 #ifdef CRYST_THETA
4302 C--------------------------------------------------------------------------
4303       subroutine ebend(etheta)
4304 C
4305 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4306 C angles gamma and its derivatives in consecutive thetas and gammas.
4307 C
4308       implicit real*8 (a-h,o-z)
4309       include 'DIMENSIONS'
4310       include 'COMMON.LOCAL'
4311       include 'COMMON.GEO'
4312       include 'COMMON.INTERACT'
4313       include 'COMMON.DERIV'
4314       include 'COMMON.VAR'
4315       include 'COMMON.CHAIN'
4316       include 'COMMON.IOUNITS'
4317       include 'COMMON.NAMES'
4318       include 'COMMON.FFIELD'
4319       include 'COMMON.CONTROL'
4320       common /calcthet/ term1,term2,termm,diffak,ratak,
4321      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4322      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4323       double precision y(2),z(2)
4324       delta=0.02d0*pi
4325 c      time11=dexp(-2*time)
4326 c      time12=1.0d0
4327       etheta=0.0D0
4328 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4329       do i=ithet_start,ithet_end
4330         if (itype(i-1).eq.21) cycle
4331 C Zero the energy function and its derivative at 0 or pi.
4332         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4333         it=itype(i-1)
4334         if (i.gt.3 .and. itype(i-2).ne.21) then
4335 #ifdef OSF
4336           phii=phi(i)
4337           if (phii.ne.phii) phii=150.0
4338 #else
4339           phii=phi(i)
4340 #endif
4341           y(1)=dcos(phii)
4342           y(2)=dsin(phii)
4343         else
4344           y(1)=0.0D0
4345           y(2)=0.0D0
4346         endif
4347         if (i.lt.nres .and. itype(i).ne.21) then
4348 #ifdef OSF
4349           phii1=phi(i+1)
4350           if (phii1.ne.phii1) phii1=150.0
4351           phii1=pinorm(phii1)
4352           z(1)=cos(phii1)
4353 #else
4354           phii1=phi(i+1)
4355           z(1)=dcos(phii1)
4356 #endif
4357           z(2)=dsin(phii1)
4358         else
4359           z(1)=0.0D0
4360           z(2)=0.0D0
4361         endif
4362 C Calculate the "mean" value of theta from the part of the distribution
4363 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4364 C In following comments this theta will be referred to as t_c.
4365         thet_pred_mean=0.0d0
4366         do k=1,2
4367           athetk=athet(k,it)
4368           bthetk=bthet(k,it)
4369           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4370         enddo
4371         dthett=thet_pred_mean*ssd
4372         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4373 C Derivatives of the "mean" values in gamma1 and gamma2.
4374         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
4375         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
4376         if (theta(i).gt.pi-delta) then
4377           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4378      &         E_tc0)
4379           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4380           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4381           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4382      &        E_theta)
4383           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4384      &        E_tc)
4385         else if (theta(i).lt.delta) then
4386           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4387           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4388           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4389      &        E_theta)
4390           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4391           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4392      &        E_tc)
4393         else
4394           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4395      &        E_theta,E_tc)
4396         endif
4397         etheta=etheta+ethetai
4398         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4399      &      'ebend',i,ethetai
4400         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4401         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4402         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4403       enddo
4404 C Ufff.... We've done all this!!!
4405       return
4406       end
4407 C---------------------------------------------------------------------------
4408       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4409      &     E_tc)
4410       implicit real*8 (a-h,o-z)
4411       include 'DIMENSIONS'
4412       include 'COMMON.LOCAL'
4413       include 'COMMON.IOUNITS'
4414       common /calcthet/ term1,term2,termm,diffak,ratak,
4415      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4416      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4417 C Calculate the contributions to both Gaussian lobes.
4418 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4419 C The "polynomial part" of the "standard deviation" of this part of
4420 C the distribution.
4421         sig=polthet(3,it)
4422         do j=2,0,-1
4423           sig=sig*thet_pred_mean+polthet(j,it)
4424         enddo
4425 C Derivative of the "interior part" of the "standard deviation of the"
4426 C gamma-dependent Gaussian lobe in t_c.
4427         sigtc=3*polthet(3,it)
4428         do j=2,1,-1
4429           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4430         enddo
4431         sigtc=sig*sigtc
4432 C Set the parameters of both Gaussian lobes of the distribution.
4433 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4434         fac=sig*sig+sigc0(it)
4435         sigcsq=fac+fac
4436         sigc=1.0D0/sigcsq
4437 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4438         sigsqtc=-4.0D0*sigcsq*sigtc
4439 c       print *,i,sig,sigtc,sigsqtc
4440 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4441         sigtc=-sigtc/(fac*fac)
4442 C Following variable is sigma(t_c)**(-2)
4443         sigcsq=sigcsq*sigcsq
4444         sig0i=sig0(it)
4445         sig0inv=1.0D0/sig0i**2
4446         delthec=thetai-thet_pred_mean
4447         delthe0=thetai-theta0i
4448         term1=-0.5D0*sigcsq*delthec*delthec
4449         term2=-0.5D0*sig0inv*delthe0*delthe0
4450 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4451 C NaNs in taking the logarithm. We extract the largest exponent which is added
4452 C to the energy (this being the log of the distribution) at the end of energy
4453 C term evaluation for this virtual-bond angle.
4454         if (term1.gt.term2) then
4455           termm=term1
4456           term2=dexp(term2-termm)
4457           term1=1.0d0
4458         else
4459           termm=term2
4460           term1=dexp(term1-termm)
4461           term2=1.0d0
4462         endif
4463 C The ratio between the gamma-independent and gamma-dependent lobes of
4464 C the distribution is a Gaussian function of thet_pred_mean too.
4465         diffak=gthet(2,it)-thet_pred_mean
4466         ratak=diffak/gthet(3,it)**2
4467         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4468 C Let's differentiate it in thet_pred_mean NOW.
4469         aktc=ak*ratak
4470 C Now put together the distribution terms to make complete distribution.
4471         termexp=term1+ak*term2
4472         termpre=sigc+ak*sig0i
4473 C Contribution of the bending energy from this theta is just the -log of
4474 C the sum of the contributions from the two lobes and the pre-exponential
4475 C factor. Simple enough, isn't it?
4476         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4477 C NOW the derivatives!!!
4478 C 6/6/97 Take into account the deformation.
4479         E_theta=(delthec*sigcsq*term1
4480      &       +ak*delthe0*sig0inv*term2)/termexp
4481         E_tc=((sigtc+aktc*sig0i)/termpre
4482      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4483      &       aktc*term2)/termexp)
4484       return
4485       end
4486 c-----------------------------------------------------------------------------
4487       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4488       implicit real*8 (a-h,o-z)
4489       include 'DIMENSIONS'
4490       include 'COMMON.LOCAL'
4491       include 'COMMON.IOUNITS'
4492       common /calcthet/ term1,term2,termm,diffak,ratak,
4493      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4494      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4495       delthec=thetai-thet_pred_mean
4496       delthe0=thetai-theta0i
4497 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4498       t3 = thetai-thet_pred_mean
4499       t6 = t3**2
4500       t9 = term1
4501       t12 = t3*sigcsq
4502       t14 = t12+t6*sigsqtc
4503       t16 = 1.0d0
4504       t21 = thetai-theta0i
4505       t23 = t21**2
4506       t26 = term2
4507       t27 = t21*t26
4508       t32 = termexp
4509       t40 = t32**2
4510       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4511      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4512      & *(-t12*t9-ak*sig0inv*t27)
4513       return
4514       end
4515 #else
4516 C--------------------------------------------------------------------------
4517       subroutine ebend(etheta)
4518 C
4519 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4520 C angles gamma and its derivatives in consecutive thetas and gammas.
4521 C ab initio-derived potentials from
4522 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4523 C
4524       implicit real*8 (a-h,o-z)
4525       include 'DIMENSIONS'
4526       include 'COMMON.LOCAL'
4527       include 'COMMON.GEO'
4528       include 'COMMON.INTERACT'
4529       include 'COMMON.DERIV'
4530       include 'COMMON.VAR'
4531       include 'COMMON.CHAIN'
4532       include 'COMMON.IOUNITS'
4533       include 'COMMON.NAMES'
4534       include 'COMMON.FFIELD'
4535       include 'COMMON.CONTROL'
4536       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4537      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4538      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4539      & sinph1ph2(maxdouble,maxdouble)
4540       logical lprn /.false./, lprn1 /.false./
4541       etheta=0.0D0
4542       do i=ithet_start,ithet_end
4543         if (itype(i-1).eq.21) cycle
4544         dethetai=0.0d0
4545         dephii=0.0d0
4546         dephii1=0.0d0
4547         theti2=0.5d0*theta(i)
4548         ityp2=ithetyp(itype(i-1))
4549         do k=1,nntheterm
4550           coskt(k)=dcos(k*theti2)
4551           sinkt(k)=dsin(k*theti2)
4552         enddo
4553         if (i.gt.3 .and. itype(i-2).ne.21) then
4554 #ifdef OSF
4555           phii=phi(i)
4556           if (phii.ne.phii) phii=150.0
4557 #else
4558           phii=phi(i)
4559 #endif
4560           ityp1=ithetyp(itype(i-2))
4561           do k=1,nsingle
4562             cosph1(k)=dcos(k*phii)
4563             sinph1(k)=dsin(k*phii)
4564           enddo
4565         else
4566           phii=0.0d0
4567           ityp1=nthetyp+1
4568           do k=1,nsingle
4569             cosph1(k)=0.0d0
4570             sinph1(k)=0.0d0
4571           enddo
4572         endif
4573         if (i.lt.nres .and. itype(i).ne.21) then
4574 #ifdef OSF
4575           phii1=phi(i+1)
4576           if (phii1.ne.phii1) phii1=150.0
4577           phii1=pinorm(phii1)
4578 #else
4579           phii1=phi(i+1)
4580 #endif
4581           ityp3=ithetyp(itype(i))
4582           do k=1,nsingle
4583             cosph2(k)=dcos(k*phii1)
4584             sinph2(k)=dsin(k*phii1)
4585           enddo
4586         else
4587           phii1=0.0d0
4588           ityp3=nthetyp+1
4589           do k=1,nsingle
4590             cosph2(k)=0.0d0
4591             sinph2(k)=0.0d0
4592           enddo
4593         endif
4594         ethetai=aa0thet(ityp1,ityp2,ityp3)
4595         do k=1,ndouble
4596           do l=1,k-1
4597             ccl=cosph1(l)*cosph2(k-l)
4598             ssl=sinph1(l)*sinph2(k-l)
4599             scl=sinph1(l)*cosph2(k-l)
4600             csl=cosph1(l)*sinph2(k-l)
4601             cosph1ph2(l,k)=ccl-ssl
4602             cosph1ph2(k,l)=ccl+ssl
4603             sinph1ph2(l,k)=scl+csl
4604             sinph1ph2(k,l)=scl-csl
4605           enddo
4606         enddo
4607         if (lprn) then
4608         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4609      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4610         write (iout,*) "coskt and sinkt"
4611         do k=1,nntheterm
4612           write (iout,*) k,coskt(k),sinkt(k)
4613         enddo
4614         endif
4615         do k=1,ntheterm
4616           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4617           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4618      &      *coskt(k)
4619           if (lprn)
4620      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4621      &     " ethetai",ethetai
4622         enddo
4623         if (lprn) then
4624         write (iout,*) "cosph and sinph"
4625         do k=1,nsingle
4626           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4627         enddo
4628         write (iout,*) "cosph1ph2 and sinph2ph2"
4629         do k=2,ndouble
4630           do l=1,k-1
4631             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4632      &         sinph1ph2(l,k),sinph1ph2(k,l)
4633           enddo
4634         enddo
4635         write(iout,*) "ethetai",ethetai
4636         endif
4637         do m=1,ntheterm2
4638           do k=1,nsingle
4639             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4640      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4641      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4642      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4643             ethetai=ethetai+sinkt(m)*aux
4644             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4645             dephii=dephii+k*sinkt(m)*(
4646      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4647      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4648             dephii1=dephii1+k*sinkt(m)*(
4649      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4650      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4651             if (lprn)
4652      &      write (iout,*) "m",m," k",k," bbthet",
4653      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4654      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4655      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4656      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4657           enddo
4658         enddo
4659         if (lprn)
4660      &  write(iout,*) "ethetai",ethetai
4661         do m=1,ntheterm3
4662           do k=2,ndouble
4663             do l=1,k-1
4664               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4665      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4666      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4667      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4668               ethetai=ethetai+sinkt(m)*aux
4669               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4670               dephii=dephii+l*sinkt(m)*(
4671      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4672      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4673      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4674      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4675               dephii1=dephii1+(k-l)*sinkt(m)*(
4676      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4677      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4678      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4679      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4680               if (lprn) then
4681               write (iout,*) "m",m," k",k," l",l," ffthet",
4682      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4683      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4684      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4685      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4686               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4687      &            cosph1ph2(k,l)*sinkt(m),
4688      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4689               endif
4690             enddo
4691           enddo
4692         enddo
4693 10      continue
4694         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4695      &   i,theta(i)*rad2deg,phii*rad2deg,
4696      &   phii1*rad2deg,ethetai
4697         etheta=etheta+ethetai
4698         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4699         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4700         gloc(nphi+i-2,icg)=wang*dethetai
4701       enddo
4702       return
4703       end
4704 #endif
4705 #ifdef CRYST_SC
4706 c-----------------------------------------------------------------------------
4707       subroutine esc(escloc)
4708 C Calculate the local energy of a side chain and its derivatives in the
4709 C corresponding virtual-bond valence angles THETA and the spherical angles
4710 C ALPHA and OMEGA.
4711       implicit real*8 (a-h,o-z)
4712       include 'DIMENSIONS'
4713       include 'COMMON.GEO'
4714       include 'COMMON.LOCAL'
4715       include 'COMMON.VAR'
4716       include 'COMMON.INTERACT'
4717       include 'COMMON.DERIV'
4718       include 'COMMON.CHAIN'
4719       include 'COMMON.IOUNITS'
4720       include 'COMMON.NAMES'
4721       include 'COMMON.FFIELD'
4722       include 'COMMON.CONTROL'
4723       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4724      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4725       common /sccalc/ time11,time12,time112,theti,it,nlobit
4726       delta=0.02d0*pi
4727       escloc=0.0D0
4728 c     write (iout,'(a)') 'ESC'
4729       do i=loc_start,loc_end
4730         it=itype(i)
4731         if (it.eq.21) cycle
4732         if (it.eq.10) goto 1
4733         nlobit=nlob(it)
4734 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4735 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4736         theti=theta(i+1)-pipol
4737         x(1)=dtan(theti)
4738         x(2)=alph(i)
4739         x(3)=omeg(i)
4740
4741         if (x(2).gt.pi-delta) then
4742           xtemp(1)=x(1)
4743           xtemp(2)=pi-delta
4744           xtemp(3)=x(3)
4745           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4746           xtemp(2)=pi
4747           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4748           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4749      &        escloci,dersc(2))
4750           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4751      &        ddersc0(1),dersc(1))
4752           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4753      &        ddersc0(3),dersc(3))
4754           xtemp(2)=pi-delta
4755           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4756           xtemp(2)=pi
4757           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4758           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4759      &            dersc0(2),esclocbi,dersc02)
4760           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4761      &            dersc12,dersc01)
4762           call splinthet(x(2),0.5d0*delta,ss,ssd)
4763           dersc0(1)=dersc01
4764           dersc0(2)=dersc02
4765           dersc0(3)=0.0d0
4766           do k=1,3
4767             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4768           enddo
4769           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4770 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4771 c    &             esclocbi,ss,ssd
4772           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4773 c         escloci=esclocbi
4774 c         write (iout,*) escloci
4775         else if (x(2).lt.delta) then
4776           xtemp(1)=x(1)
4777           xtemp(2)=delta
4778           xtemp(3)=x(3)
4779           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4780           xtemp(2)=0.0d0
4781           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4782           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4783      &        escloci,dersc(2))
4784           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4785      &        ddersc0(1),dersc(1))
4786           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4787      &        ddersc0(3),dersc(3))
4788           xtemp(2)=delta
4789           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4790           xtemp(2)=0.0d0
4791           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4792           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4793      &            dersc0(2),esclocbi,dersc02)
4794           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4795      &            dersc12,dersc01)
4796           dersc0(1)=dersc01
4797           dersc0(2)=dersc02
4798           dersc0(3)=0.0d0
4799           call splinthet(x(2),0.5d0*delta,ss,ssd)
4800           do k=1,3
4801             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4802           enddo
4803           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4804 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4805 c    &             esclocbi,ss,ssd
4806           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4807 c         write (iout,*) escloci
4808         else
4809           call enesc(x,escloci,dersc,ddummy,.false.)
4810         endif
4811
4812         escloc=escloc+escloci
4813         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4814      &     'escloc',i,escloci
4815 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4816
4817         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4818      &   wscloc*dersc(1)
4819         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4820         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4821     1   continue
4822       enddo
4823       return
4824       end
4825 C---------------------------------------------------------------------------
4826       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4827       implicit real*8 (a-h,o-z)
4828       include 'DIMENSIONS'
4829       include 'COMMON.GEO'
4830       include 'COMMON.LOCAL'
4831       include 'COMMON.IOUNITS'
4832       common /sccalc/ time11,time12,time112,theti,it,nlobit
4833       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4834       double precision contr(maxlob,-1:1)
4835       logical mixed
4836 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4837         escloc_i=0.0D0
4838         do j=1,3
4839           dersc(j)=0.0D0
4840           if (mixed) ddersc(j)=0.0d0
4841         enddo
4842         x3=x(3)
4843
4844 C Because of periodicity of the dependence of the SC energy in omega we have
4845 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4846 C To avoid underflows, first compute & store the exponents.
4847
4848         do iii=-1,1
4849
4850           x(3)=x3+iii*dwapi
4851
4852           do j=1,nlobit
4853             do k=1,3
4854               z(k)=x(k)-censc(k,j,it)
4855             enddo
4856             do k=1,3
4857               Axk=0.0D0
4858               do l=1,3
4859                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4860               enddo
4861               Ax(k,j,iii)=Axk
4862             enddo
4863             expfac=0.0D0
4864             do k=1,3
4865               expfac=expfac+Ax(k,j,iii)*z(k)
4866             enddo
4867             contr(j,iii)=expfac
4868           enddo ! j
4869
4870         enddo ! iii
4871
4872         x(3)=x3
4873 C As in the case of ebend, we want to avoid underflows in exponentiation and
4874 C subsequent NaNs and INFs in energy calculation.
4875 C Find the largest exponent
4876         emin=contr(1,-1)
4877         do iii=-1,1
4878           do j=1,nlobit
4879             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4880           enddo
4881         enddo
4882         emin=0.5D0*emin
4883 cd      print *,'it=',it,' emin=',emin
4884
4885 C Compute the contribution to SC energy and derivatives
4886         do iii=-1,1
4887
4888           do j=1,nlobit
4889 #ifdef OSF
4890             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4891             if(adexp.ne.adexp) adexp=1.0
4892             expfac=dexp(adexp)
4893 #else
4894             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4895 #endif
4896 cd          print *,'j=',j,' expfac=',expfac
4897             escloc_i=escloc_i+expfac
4898             do k=1,3
4899               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4900             enddo
4901             if (mixed) then
4902               do k=1,3,2
4903                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4904      &            +gaussc(k,2,j,it))*expfac
4905               enddo
4906             endif
4907           enddo
4908
4909         enddo ! iii
4910
4911         dersc(1)=dersc(1)/cos(theti)**2
4912         ddersc(1)=ddersc(1)/cos(theti)**2
4913         ddersc(3)=ddersc(3)
4914
4915         escloci=-(dlog(escloc_i)-emin)
4916         do j=1,3
4917           dersc(j)=dersc(j)/escloc_i
4918         enddo
4919         if (mixed) then
4920           do j=1,3,2
4921             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4922           enddo
4923         endif
4924       return
4925       end
4926 C------------------------------------------------------------------------------
4927       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4928       implicit real*8 (a-h,o-z)
4929       include 'DIMENSIONS'
4930       include 'COMMON.GEO'
4931       include 'COMMON.LOCAL'
4932       include 'COMMON.IOUNITS'
4933       common /sccalc/ time11,time12,time112,theti,it,nlobit
4934       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4935       double precision contr(maxlob)
4936       logical mixed
4937
4938       escloc_i=0.0D0
4939
4940       do j=1,3
4941         dersc(j)=0.0D0
4942       enddo
4943
4944       do j=1,nlobit
4945         do k=1,2
4946           z(k)=x(k)-censc(k,j,it)
4947         enddo
4948         z(3)=dwapi
4949         do k=1,3
4950           Axk=0.0D0
4951           do l=1,3
4952             Axk=Axk+gaussc(l,k,j,it)*z(l)
4953           enddo
4954           Ax(k,j)=Axk
4955         enddo
4956         expfac=0.0D0
4957         do k=1,3
4958           expfac=expfac+Ax(k,j)*z(k)
4959         enddo
4960         contr(j)=expfac
4961       enddo ! j
4962
4963 C As in the case of ebend, we want to avoid underflows in exponentiation and
4964 C subsequent NaNs and INFs in energy calculation.
4965 C Find the largest exponent
4966       emin=contr(1)
4967       do j=1,nlobit
4968         if (emin.gt.contr(j)) emin=contr(j)
4969       enddo
4970       emin=0.5D0*emin
4971
4972 C Compute the contribution to SC energy and derivatives
4973
4974       dersc12=0.0d0
4975       do j=1,nlobit
4976         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4977         escloc_i=escloc_i+expfac
4978         do k=1,2
4979           dersc(k)=dersc(k)+Ax(k,j)*expfac
4980         enddo
4981         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4982      &            +gaussc(1,2,j,it))*expfac
4983         dersc(3)=0.0d0
4984       enddo
4985
4986       dersc(1)=dersc(1)/cos(theti)**2
4987       dersc12=dersc12/cos(theti)**2
4988       escloci=-(dlog(escloc_i)-emin)
4989       do j=1,2
4990         dersc(j)=dersc(j)/escloc_i
4991       enddo
4992       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4993       return
4994       end
4995 #else
4996 c----------------------------------------------------------------------------------
4997       subroutine esc(escloc)
4998 C Calculate the local energy of a side chain and its derivatives in the
4999 C corresponding virtual-bond valence angles THETA and the spherical angles
5000 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5001 C added by Urszula Kozlowska. 07/11/2007
5002 C
5003       implicit real*8 (a-h,o-z)
5004       include 'DIMENSIONS'
5005       include 'COMMON.GEO'
5006       include 'COMMON.LOCAL'
5007       include 'COMMON.VAR'
5008       include 'COMMON.SCROT'
5009       include 'COMMON.INTERACT'
5010       include 'COMMON.DERIV'
5011       include 'COMMON.CHAIN'
5012       include 'COMMON.IOUNITS'
5013       include 'COMMON.NAMES'
5014       include 'COMMON.FFIELD'
5015       include 'COMMON.CONTROL'
5016       include 'COMMON.VECTORS'
5017       double precision x_prime(3),y_prime(3),z_prime(3)
5018      &    , sumene,dsc_i,dp2_i,x(65),
5019      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5020      &    de_dxx,de_dyy,de_dzz,de_dt
5021       double precision s1_t,s1_6_t,s2_t,s2_6_t
5022       double precision
5023      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5024      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5025      & dt_dCi(3),dt_dCi1(3)
5026       common /sccalc/ time11,time12,time112,theti,it,nlobit
5027       delta=0.02d0*pi
5028       escloc=0.0D0
5029       do i=loc_start,loc_end
5030         if (itype(i).eq.21) cycle
5031         costtab(i+1) =dcos(theta(i+1))
5032         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5033         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5034         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5035         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5036         cosfac=dsqrt(cosfac2)
5037         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5038         sinfac=dsqrt(sinfac2)
5039         it=itype(i)
5040         if (it.eq.10) goto 1
5041 c
5042 C  Compute the axes of tghe local cartesian coordinates system; store in
5043 c   x_prime, y_prime and z_prime
5044 c
5045         do j=1,3
5046           x_prime(j) = 0.00
5047           y_prime(j) = 0.00
5048           z_prime(j) = 0.00
5049         enddo
5050 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5051 C     &   dc_norm(3,i+nres)
5052         do j = 1,3
5053           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5054           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5055         enddo
5056         do j = 1,3
5057           z_prime(j) = -uz(j,i-1)
5058         enddo
5059 c       write (2,*) "i",i
5060 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5061 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5062 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5063 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5064 c      & " xy",scalar(x_prime(1),y_prime(1)),
5065 c      & " xz",scalar(x_prime(1),z_prime(1)),
5066 c      & " yy",scalar(y_prime(1),y_prime(1)),
5067 c      & " yz",scalar(y_prime(1),z_prime(1)),
5068 c      & " zz",scalar(z_prime(1),z_prime(1))
5069 c
5070 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5071 C to local coordinate system. Store in xx, yy, zz.
5072 c
5073         xx=0.0d0
5074         yy=0.0d0
5075         zz=0.0d0
5076         do j = 1,3
5077           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5078           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5079           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5080         enddo
5081
5082         xxtab(i)=xx
5083         yytab(i)=yy
5084         zztab(i)=zz
5085 C
5086 C Compute the energy of the ith side cbain
5087 C
5088 c        write (2,*) "xx",xx," yy",yy," zz",zz
5089         it=itype(i)
5090         do j = 1,65
5091           x(j) = sc_parmin(j,it)
5092         enddo
5093 #ifdef CHECK_COORD
5094 Cc diagnostics - remove later
5095         xx1 = dcos(alph(2))
5096         yy1 = dsin(alph(2))*dcos(omeg(2))
5097         zz1 = -dsin(alph(2))*dsin(omeg(2))
5098         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5099      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5100      &    xx1,yy1,zz1
5101 C,"  --- ", xx_w,yy_w,zz_w
5102 c end diagnostics
5103 #endif
5104         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5105      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5106      &   + x(10)*yy*zz
5107         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5108      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5109      & + x(20)*yy*zz
5110         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5111      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5112      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5113      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5114      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5115      &  +x(40)*xx*yy*zz
5116         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5117      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5118      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5119      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5120      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5121      &  +x(60)*xx*yy*zz
5122         dsc_i   = 0.743d0+x(61)
5123         dp2_i   = 1.9d0+x(62)
5124         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5125      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5126         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5127      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5128         s1=(1+x(63))/(0.1d0 + dscp1)
5129         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5130         s2=(1+x(65))/(0.1d0 + dscp2)
5131         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5132         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5133      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5134 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5135 c     &   sumene4,
5136 c     &   dscp1,dscp2,sumene
5137 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5138         escloc = escloc + sumene
5139 c        write (2,*) "i",i," escloc",sumene,escloc
5140 #ifdef DEBUG
5141 C
5142 C This section to check the numerical derivatives of the energy of ith side
5143 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5144 C #define DEBUG in the code to turn it on.
5145 C
5146         write (2,*) "sumene               =",sumene
5147         aincr=1.0d-7
5148         xxsave=xx
5149         xx=xx+aincr
5150         write (2,*) xx,yy,zz
5151         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5152         de_dxx_num=(sumenep-sumene)/aincr
5153         xx=xxsave
5154         write (2,*) "xx+ sumene from enesc=",sumenep
5155         yysave=yy
5156         yy=yy+aincr
5157         write (2,*) xx,yy,zz
5158         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5159         de_dyy_num=(sumenep-sumene)/aincr
5160         yy=yysave
5161         write (2,*) "yy+ sumene from enesc=",sumenep
5162         zzsave=zz
5163         zz=zz+aincr
5164         write (2,*) xx,yy,zz
5165         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5166         de_dzz_num=(sumenep-sumene)/aincr
5167         zz=zzsave
5168         write (2,*) "zz+ sumene from enesc=",sumenep
5169         costsave=cost2tab(i+1)
5170         sintsave=sint2tab(i+1)
5171         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5172         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5173         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5174         de_dt_num=(sumenep-sumene)/aincr
5175         write (2,*) " t+ sumene from enesc=",sumenep
5176         cost2tab(i+1)=costsave
5177         sint2tab(i+1)=sintsave
5178 C End of diagnostics section.
5179 #endif
5180 C
5181 C Compute the gradient of esc
5182 C
5183         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5184         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5185         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5186         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5187         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5188         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5189         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5190         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5191         pom1=(sumene3*sint2tab(i+1)+sumene1)
5192      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5193         pom2=(sumene4*cost2tab(i+1)+sumene2)
5194      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5195         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5196         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5197      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5198      &  +x(40)*yy*zz
5199         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5200         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5201      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5202      &  +x(60)*yy*zz
5203         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5204      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5205      &        +(pom1+pom2)*pom_dx
5206 #ifdef DEBUG
5207         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5208 #endif
5209 C
5210         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5211         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5212      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5213      &  +x(40)*xx*zz
5214         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5215         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5216      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5217      &  +x(59)*zz**2 +x(60)*xx*zz
5218         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5219      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5220      &        +(pom1-pom2)*pom_dy
5221 #ifdef DEBUG
5222         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5223 #endif
5224 C
5225         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5226      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5227      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5228      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5229      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5230      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5231      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5232      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5233 #ifdef DEBUG
5234         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5235 #endif
5236 C
5237         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5238      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5239      &  +pom1*pom_dt1+pom2*pom_dt2
5240 #ifdef DEBUG
5241         write(2,*), "de_dt = ", de_dt,de_dt_num
5242 #endif
5243 c
5244 C
5245        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5246        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5247        cosfac2xx=cosfac2*xx
5248        sinfac2yy=sinfac2*yy
5249        do k = 1,3
5250          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5251      &      vbld_inv(i+1)
5252          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5253      &      vbld_inv(i)
5254          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5255          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5256 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5257 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5258 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5259 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5260          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5261          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5262          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5263          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5264          dZZ_Ci1(k)=0.0d0
5265          dZZ_Ci(k)=0.0d0
5266          do j=1,3
5267            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
5268            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
5269          enddo
5270
5271          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5272          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5273          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5274 c
5275          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5276          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5277        enddo
5278
5279        do k=1,3
5280          dXX_Ctab(k,i)=dXX_Ci(k)
5281          dXX_C1tab(k,i)=dXX_Ci1(k)
5282          dYY_Ctab(k,i)=dYY_Ci(k)
5283          dYY_C1tab(k,i)=dYY_Ci1(k)
5284          dZZ_Ctab(k,i)=dZZ_Ci(k)
5285          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5286          dXX_XYZtab(k,i)=dXX_XYZ(k)
5287          dYY_XYZtab(k,i)=dYY_XYZ(k)
5288          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5289        enddo
5290
5291        do k = 1,3
5292 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5293 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5294 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5295 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5296 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5297 c     &    dt_dci(k)
5298 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5299 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5300          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5301      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5302          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5303      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5304          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5305      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5306        enddo
5307 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5308 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5309
5310 C to check gradient call subroutine check_grad
5311
5312     1 continue
5313       enddo
5314       return
5315       end
5316 c------------------------------------------------------------------------------
5317       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5318       implicit none
5319       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5320      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5321       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5322      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5323      &   + x(10)*yy*zz
5324       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5325      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5326      & + x(20)*yy*zz
5327       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5328      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5329      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5330      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5331      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5332      &  +x(40)*xx*yy*zz
5333       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5334      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5335      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5336      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5337      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5338      &  +x(60)*xx*yy*zz
5339       dsc_i   = 0.743d0+x(61)
5340       dp2_i   = 1.9d0+x(62)
5341       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5342      &          *(xx*cost2+yy*sint2))
5343       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5344      &          *(xx*cost2-yy*sint2))
5345       s1=(1+x(63))/(0.1d0 + dscp1)
5346       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5347       s2=(1+x(65))/(0.1d0 + dscp2)
5348       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5349       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5350      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5351       enesc=sumene
5352       return
5353       end
5354 #endif
5355 c------------------------------------------------------------------------------
5356       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5357 C
5358 C This procedure calculates two-body contact function g(rij) and its derivative:
5359 C
5360 C           eps0ij                                     !       x < -1
5361 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5362 C            0                                         !       x > 1
5363 C
5364 C where x=(rij-r0ij)/delta
5365 C
5366 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5367 C
5368       implicit none
5369       double precision rij,r0ij,eps0ij,fcont,fprimcont
5370       double precision x,x2,x4,delta
5371 c     delta=0.02D0*r0ij
5372 c      delta=0.2D0*r0ij
5373       x=(rij-r0ij)/delta
5374       if (x.lt.-1.0D0) then
5375         fcont=eps0ij
5376         fprimcont=0.0D0
5377       else if (x.le.1.0D0) then
5378         x2=x*x
5379         x4=x2*x2
5380         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5381         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5382       else
5383         fcont=0.0D0
5384         fprimcont=0.0D0
5385       endif
5386       return
5387       end
5388 c------------------------------------------------------------------------------
5389       subroutine splinthet(theti,delta,ss,ssder)
5390       implicit real*8 (a-h,o-z)
5391       include 'DIMENSIONS'
5392       include 'COMMON.VAR'
5393       include 'COMMON.GEO'
5394       thetup=pi-delta
5395       thetlow=delta
5396       if (theti.gt.pipol) then
5397         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5398       else
5399         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5400         ssder=-ssder
5401       endif
5402       return
5403       end
5404 c------------------------------------------------------------------------------
5405       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5406       implicit none
5407       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5408       double precision ksi,ksi2,ksi3,a1,a2,a3
5409       a1=fprim0*delta/(f1-f0)
5410       a2=3.0d0-2.0d0*a1
5411       a3=a1-2.0d0
5412       ksi=(x-x0)/delta
5413       ksi2=ksi*ksi
5414       ksi3=ksi2*ksi
5415       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5416       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5417       return
5418       end
5419 c------------------------------------------------------------------------------
5420       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5421       implicit none
5422       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5423       double precision ksi,ksi2,ksi3,a1,a2,a3
5424       ksi=(x-x0)/delta
5425       ksi2=ksi*ksi
5426       ksi3=ksi2*ksi
5427       a1=fprim0x*delta
5428       a2=3*(f1x-f0x)-2*fprim0x*delta
5429       a3=fprim0x*delta-2*(f1x-f0x)
5430       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5431       return
5432       end
5433 C-----------------------------------------------------------------------------
5434 #ifdef CRYST_TOR
5435 C-----------------------------------------------------------------------------
5436       subroutine etor(etors,edihcnstr)
5437       implicit real*8 (a-h,o-z)
5438       include 'DIMENSIONS'
5439       include 'COMMON.VAR'
5440       include 'COMMON.GEO'
5441       include 'COMMON.LOCAL'
5442       include 'COMMON.TORSION'
5443       include 'COMMON.INTERACT'
5444       include 'COMMON.DERIV'
5445       include 'COMMON.CHAIN'
5446       include 'COMMON.NAMES'
5447       include 'COMMON.IOUNITS'
5448       include 'COMMON.FFIELD'
5449       include 'COMMON.TORCNSTR'
5450       include 'COMMON.CONTROL'
5451       logical lprn
5452 C Set lprn=.true. for debugging
5453       lprn=.false.
5454 c      lprn=.true.
5455       etors=0.0D0
5456       do i=iphi_start,iphi_end
5457       etors_ii=0.0D0
5458         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5459      &      .or. itype(i).eq.21) cycle
5460         itori=itortyp(itype(i-2))
5461         itori1=itortyp(itype(i-1))
5462         phii=phi(i)
5463         gloci=0.0D0
5464 C Proline-Proline pair is a special case...
5465         if (itori.eq.3 .and. itori1.eq.3) then
5466           if (phii.gt.-dwapi3) then
5467             cosphi=dcos(3*phii)
5468             fac=1.0D0/(1.0D0-cosphi)
5469             etorsi=v1(1,3,3)*fac
5470             etorsi=etorsi+etorsi
5471             etors=etors+etorsi-v1(1,3,3)
5472             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5473             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5474           endif
5475           do j=1,3
5476             v1ij=v1(j+1,itori,itori1)
5477             v2ij=v2(j+1,itori,itori1)
5478             cosphi=dcos(j*phii)
5479             sinphi=dsin(j*phii)
5480             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5481             if (energy_dec) etors_ii=etors_ii+
5482      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5483             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5484           enddo
5485         else
5486           do j=1,nterm_old
5487             v1ij=v1(j,itori,itori1)
5488             v2ij=v2(j,itori,itori1)
5489             cosphi=dcos(j*phii)
5490             sinphi=dsin(j*phii)
5491             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5492             if (energy_dec) etors_ii=etors_ii+
5493      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5494             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5495           enddo
5496         endif
5497         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5498              'etor',i,etors_ii
5499         if (lprn)
5500      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5501      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5502      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5503         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5504 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5505       enddo
5506 ! 6/20/98 - dihedral angle constraints
5507       edihcnstr=0.0d0
5508       do i=1,ndih_constr
5509         itori=idih_constr(i)
5510         phii=phi(itori)
5511         difi=phii-phi0(i)
5512         if (difi.gt.drange(i)) then
5513           difi=difi-drange(i)
5514           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5515           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5516         else if (difi.lt.-drange(i)) then
5517           difi=difi+drange(i)
5518           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5519           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5520         endif
5521 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5522 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5523       enddo
5524 !      write (iout,*) 'edihcnstr',edihcnstr
5525       return
5526       end
5527 c------------------------------------------------------------------------------
5528       subroutine etor_d(etors_d)
5529       etors_d=0.0d0
5530       return
5531       end
5532 c----------------------------------------------------------------------------
5533 #else
5534       subroutine etor(etors,edihcnstr)
5535       implicit real*8 (a-h,o-z)
5536       include 'DIMENSIONS'
5537       include 'COMMON.VAR'
5538       include 'COMMON.GEO'
5539       include 'COMMON.LOCAL'
5540       include 'COMMON.TORSION'
5541       include 'COMMON.INTERACT'
5542       include 'COMMON.DERIV'
5543       include 'COMMON.CHAIN'
5544       include 'COMMON.NAMES'
5545       include 'COMMON.IOUNITS'
5546       include 'COMMON.FFIELD'
5547       include 'COMMON.TORCNSTR'
5548       include 'COMMON.CONTROL'
5549       logical lprn
5550 C Set lprn=.true. for debugging
5551       lprn=.false.
5552 c     lprn=.true.
5553       etors=0.0D0
5554       do i=iphi_start,iphi_end
5555         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5556      &       .or. itype(i).eq.21) cycle
5557       etors_ii=0.0D0
5558         itori=itortyp(itype(i-2))
5559         itori1=itortyp(itype(i-1))
5560         phii=phi(i)
5561         gloci=0.0D0
5562 C Regular cosine and sine terms
5563         do j=1,nterm(itori,itori1)
5564           v1ij=v1(j,itori,itori1)
5565           v2ij=v2(j,itori,itori1)
5566           cosphi=dcos(j*phii)
5567           sinphi=dsin(j*phii)
5568           etors=etors+v1ij*cosphi+v2ij*sinphi
5569           if (energy_dec) etors_ii=etors_ii+
5570      &                v1ij*cosphi+v2ij*sinphi
5571           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5572         enddo
5573 C Lorentz terms
5574 C                         v1
5575 C  E = SUM ----------------------------------- - v1
5576 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5577 C
5578         cosphi=dcos(0.5d0*phii)
5579         sinphi=dsin(0.5d0*phii)
5580         do j=1,nlor(itori,itori1)
5581           vl1ij=vlor1(j,itori,itori1)
5582           vl2ij=vlor2(j,itori,itori1)
5583           vl3ij=vlor3(j,itori,itori1)
5584           pom=vl2ij*cosphi+vl3ij*sinphi
5585           pom1=1.0d0/(pom*pom+1.0d0)
5586           etors=etors+vl1ij*pom1
5587           if (energy_dec) etors_ii=etors_ii+
5588      &                vl1ij*pom1
5589           pom=-pom*pom1*pom1
5590           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5591         enddo
5592 C Subtract the constant term
5593         etors=etors-v0(itori,itori1)
5594           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5595      &         'etor',i,etors_ii-v0(itori,itori1)
5596         if (lprn)
5597      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5598      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5599      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5600         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5601 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5602       enddo
5603 ! 6/20/98 - dihedral angle constraints
5604       edihcnstr=0.0d0
5605 c      do i=1,ndih_constr
5606       do i=idihconstr_start,idihconstr_end
5607         itori=idih_constr(i)
5608         phii=phi(itori)
5609         difi=pinorm(phii-phi0(i))
5610         if (difi.gt.drange(i)) then
5611           difi=difi-drange(i)
5612           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5613           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5614         else if (difi.lt.-drange(i)) then
5615           difi=difi+drange(i)
5616           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5617           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5618         else
5619           difi=0.0
5620         endif
5621 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5622 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5623 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5624       enddo
5625 cd       write (iout,*) 'edihcnstr',edihcnstr
5626       return
5627       end
5628 c----------------------------------------------------------------------------
5629       subroutine etor_d(etors_d)
5630 C 6/23/01 Compute double torsional energy
5631       implicit real*8 (a-h,o-z)
5632       include 'DIMENSIONS'
5633       include 'COMMON.VAR'
5634       include 'COMMON.GEO'
5635       include 'COMMON.LOCAL'
5636       include 'COMMON.TORSION'
5637       include 'COMMON.INTERACT'
5638       include 'COMMON.DERIV'
5639       include 'COMMON.CHAIN'
5640       include 'COMMON.NAMES'
5641       include 'COMMON.IOUNITS'
5642       include 'COMMON.FFIELD'
5643       include 'COMMON.TORCNSTR'
5644       logical lprn
5645 C Set lprn=.true. for debugging
5646       lprn=.false.
5647 c     lprn=.true.
5648       etors_d=0.0D0
5649       do i=iphid_start,iphid_end
5650         if (itype(i-2).eq.21 .or. itype(i-1).eq.21
5651      &      .or. itype(i).eq.21 .or. itype(i+1).eq.21) cycle
5652         itori=itortyp(itype(i-2))
5653         itori1=itortyp(itype(i-1))
5654         itori2=itortyp(itype(i))
5655         phii=phi(i)
5656         phii1=phi(i+1)
5657         gloci1=0.0D0
5658         gloci2=0.0D0
5659 C Regular cosine and sine terms
5660         do j=1,ntermd_1(itori,itori1,itori2)
5661           v1cij=v1c(1,j,itori,itori1,itori2)
5662           v1sij=v1s(1,j,itori,itori1,itori2)
5663           v2cij=v1c(2,j,itori,itori1,itori2)
5664           v2sij=v1s(2,j,itori,itori1,itori2)
5665           cosphi1=dcos(j*phii)
5666           sinphi1=dsin(j*phii)
5667           cosphi2=dcos(j*phii1)
5668           sinphi2=dsin(j*phii1)
5669           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5670      &     v2cij*cosphi2+v2sij*sinphi2
5671           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5672           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5673         enddo
5674         do k=2,ntermd_2(itori,itori1,itori2)
5675           do l=1,k-1
5676             v1cdij = v2c(k,l,itori,itori1,itori2)
5677             v2cdij = v2c(l,k,itori,itori1,itori2)
5678             v1sdij = v2s(k,l,itori,itori1,itori2)
5679             v2sdij = v2s(l,k,itori,itori1,itori2)
5680             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5681             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5682             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5683             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5684             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5685      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5686             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5687      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5688             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5689      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5690           enddo
5691         enddo
5692         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5693         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5694       enddo
5695       return
5696       end
5697 #endif
5698 c------------------------------------------------------------------------------
5699       subroutine eback_sc_corr(esccor)
5700 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5701 c        conformational states; temporarily implemented as differences
5702 c        between UNRES torsional potentials (dependent on three types of
5703 c        residues) and the torsional potentials dependent on all 20 types
5704 c        of residues computed from AM1  energy surfaces of terminally-blocked
5705 c        amino-acid residues.
5706       implicit real*8 (a-h,o-z)
5707       include 'DIMENSIONS'
5708       include 'COMMON.VAR'
5709       include 'COMMON.GEO'
5710       include 'COMMON.LOCAL'
5711       include 'COMMON.TORSION'
5712       include 'COMMON.SCCOR'
5713       include 'COMMON.INTERACT'
5714       include 'COMMON.DERIV'
5715       include 'COMMON.CHAIN'
5716       include 'COMMON.NAMES'
5717       include 'COMMON.IOUNITS'
5718       include 'COMMON.FFIELD'
5719       include 'COMMON.CONTROL'
5720       logical lprn
5721 C Set lprn=.true. for debugging
5722       lprn=.false.
5723 c      lprn=.true.
5724 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5725       esccor=0.0D0
5726       do i=itau_start,itau_end
5727         esccor_ii=0.0D0
5728         isccori=isccortyp(itype(i-2))
5729         isccori1=isccortyp(itype(i-1))
5730 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5731         phii=phi(i)
5732         do intertyp=1,3 !intertyp
5733 cc Added 09 May 2012 (Adasko)
5734 cc  Intertyp means interaction type of backbone mainchain correlation:
5735 c   1 = SC...Ca...Ca...Ca
5736 c   2 = Ca...Ca...Ca...SC
5737 c   3 = SC...Ca...Ca...SCi
5738         gloci=0.0D0
5739         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5740      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5741      &      (itype(i-1).eq.ntyp1)))
5742      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5743      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5744      &     .or.(itype(i).eq.ntyp1)))
5745      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5746      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5747      &      (itype(i-3).eq.ntyp1)))) cycle
5748         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5749         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5750      & cycle
5751        do j=1,nterm_sccor(isccori,isccori1)
5752           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5753           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5754           cosphi=dcos(j*tauangle(intertyp,i))
5755           sinphi=dsin(j*tauangle(intertyp,i))
5756           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5757           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5758         enddo
5759 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
5760         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5761         if (lprn)
5762      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5763      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5764      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5765      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5766         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5767        enddo !intertyp
5768       enddo
5769
5770       return
5771       end
5772 c----------------------------------------------------------------------------
5773       subroutine multibody(ecorr)
5774 C This subroutine calculates multi-body contributions to energy following
5775 C the idea of Skolnick et al. If side chains I and J make a contact and
5776 C at the same time side chains I+1 and J+1 make a contact, an extra
5777 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5778       implicit real*8 (a-h,o-z)
5779       include 'DIMENSIONS'
5780       include 'COMMON.IOUNITS'
5781       include 'COMMON.DERIV'
5782       include 'COMMON.INTERACT'
5783       include 'COMMON.CONTACTS'
5784       double precision gx(3),gx1(3)
5785       logical lprn
5786
5787 C Set lprn=.true. for debugging
5788       lprn=.false.
5789
5790       if (lprn) then
5791         write (iout,'(a)') 'Contact function values:'
5792         do i=nnt,nct-2
5793           write (iout,'(i2,20(1x,i2,f10.5))')
5794      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5795         enddo
5796       endif
5797       ecorr=0.0D0
5798       do i=nnt,nct
5799         do j=1,3
5800           gradcorr(j,i)=0.0D0
5801           gradxorr(j,i)=0.0D0
5802         enddo
5803       enddo
5804       do i=nnt,nct-2
5805
5806         DO ISHIFT = 3,4
5807
5808         i1=i+ishift
5809         num_conti=num_cont(i)
5810         num_conti1=num_cont(i1)
5811         do jj=1,num_conti
5812           j=jcont(jj,i)
5813           do kk=1,num_conti1
5814             j1=jcont(kk,i1)
5815             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5816 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5817 cd   &                   ' ishift=',ishift
5818 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5819 C The system gains extra energy.
5820               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5821             endif   ! j1==j+-ishift
5822           enddo     ! kk
5823         enddo       ! jj
5824
5825         ENDDO ! ISHIFT
5826
5827       enddo         ! i
5828       return
5829       end
5830 c------------------------------------------------------------------------------
5831       double precision function esccorr(i,j,k,l,jj,kk)
5832       implicit real*8 (a-h,o-z)
5833       include 'DIMENSIONS'
5834       include 'COMMON.IOUNITS'
5835       include 'COMMON.DERIV'
5836       include 'COMMON.INTERACT'
5837       include 'COMMON.CONTACTS'
5838       double precision gx(3),gx1(3)
5839       logical lprn
5840       lprn=.false.
5841       eij=facont(jj,i)
5842       ekl=facont(kk,k)
5843 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5844 C Calculate the multi-body contribution to energy.
5845 C Calculate multi-body contributions to the gradient.
5846 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5847 cd   & k,l,(gacont(m,kk,k),m=1,3)
5848       do m=1,3
5849         gx(m) =ekl*gacont(m,jj,i)
5850         gx1(m)=eij*gacont(m,kk,k)
5851         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5852         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5853         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5854         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5855       enddo
5856       do m=i,j-1
5857         do ll=1,3
5858           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5859         enddo
5860       enddo
5861       do m=k,l-1
5862         do ll=1,3
5863           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5864         enddo
5865       enddo
5866       esccorr=-eij*ekl
5867       return
5868       end
5869 c------------------------------------------------------------------------------
5870       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5871 C This subroutine calculates multi-body contributions to hydrogen-bonding
5872       implicit real*8 (a-h,o-z)
5873       include 'DIMENSIONS'
5874       include 'COMMON.IOUNITS'
5875 #ifdef MPI
5876       include "mpif.h"
5877       parameter (max_cont=maxconts)
5878       parameter (max_dim=26)
5879       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
5880       double precision zapas(max_dim,maxconts,max_fg_procs),
5881      &  zapas_recv(max_dim,maxconts,max_fg_procs)
5882       common /przechowalnia/ zapas
5883       integer status(MPI_STATUS_SIZE),req(maxconts*2),
5884      &  status_array(MPI_STATUS_SIZE,maxconts*2)
5885 #endif
5886       include 'COMMON.SETUP'
5887       include 'COMMON.FFIELD'
5888       include 'COMMON.DERIV'
5889       include 'COMMON.INTERACT'
5890       include 'COMMON.CONTACTS'
5891       include 'COMMON.CONTROL'
5892       include 'COMMON.LOCAL'
5893       double precision gx(3),gx1(3),time00
5894       logical lprn,ldone
5895
5896 C Set lprn=.true. for debugging
5897       lprn=.false.
5898 #ifdef MPI
5899       n_corr=0
5900       n_corr1=0
5901       if (nfgtasks.le.1) goto 30
5902       if (lprn) then
5903         write (iout,'(a)') 'Contact function values before RECEIVE:'
5904         do i=nnt,nct-2
5905           write (iout,'(2i3,50(1x,i2,f5.2))')
5906      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5907      &    j=1,num_cont_hb(i))
5908         enddo
5909       endif
5910       call flush(iout)
5911       do i=1,ntask_cont_from
5912         ncont_recv(i)=0
5913       enddo
5914       do i=1,ntask_cont_to
5915         ncont_sent(i)=0
5916       enddo
5917 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
5918 c     & ntask_cont_to
5919 C Make the list of contacts to send to send to other procesors
5920 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
5921 c      call flush(iout)
5922       do i=iturn3_start,iturn3_end
5923 c        write (iout,*) "make contact list turn3",i," num_cont",
5924 c     &    num_cont_hb(i)
5925         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
5926       enddo
5927       do i=iturn4_start,iturn4_end
5928 c        write (iout,*) "make contact list turn4",i," num_cont",
5929 c     &   num_cont_hb(i)
5930         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
5931       enddo
5932       do ii=1,nat_sent
5933         i=iat_sent(ii)
5934 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
5935 c     &    num_cont_hb(i)
5936         do j=1,num_cont_hb(i)
5937         do k=1,4
5938           jjc=jcont_hb(j,i)
5939           iproc=iint_sent_local(k,jjc,ii)
5940 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
5941           if (iproc.gt.0) then
5942             ncont_sent(iproc)=ncont_sent(iproc)+1
5943             nn=ncont_sent(iproc)
5944             zapas(1,nn,iproc)=i
5945             zapas(2,nn,iproc)=jjc
5946             zapas(3,nn,iproc)=facont_hb(j,i)
5947             zapas(4,nn,iproc)=ees0p(j,i)
5948             zapas(5,nn,iproc)=ees0m(j,i)
5949             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
5950             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
5951             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
5952             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
5953             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
5954             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
5955             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
5956             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
5957             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
5958             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
5959             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
5960             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
5961             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
5962             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
5963             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
5964             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
5965             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
5966             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
5967             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
5968             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
5969             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
5970           endif
5971         enddo
5972         enddo
5973       enddo
5974       if (lprn) then
5975       write (iout,*)
5976      &  "Numbers of contacts to be sent to other processors",
5977      &  (ncont_sent(i),i=1,ntask_cont_to)
5978       write (iout,*) "Contacts sent"
5979       do ii=1,ntask_cont_to
5980         nn=ncont_sent(ii)
5981         iproc=itask_cont_to(ii)
5982         write (iout,*) nn," contacts to processor",iproc,
5983      &   " of CONT_TO_COMM group"
5984         do i=1,nn
5985           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
5986         enddo
5987       enddo
5988       call flush(iout)
5989       endif
5990       CorrelType=477
5991       CorrelID=fg_rank+1
5992       CorrelType1=478
5993       CorrelID1=nfgtasks+fg_rank+1
5994       ireq=0
5995 C Receive the numbers of needed contacts from other processors
5996       do ii=1,ntask_cont_from
5997         iproc=itask_cont_from(ii)
5998         ireq=ireq+1
5999         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6000      &    FG_COMM,req(ireq),IERR)
6001       enddo
6002 c      write (iout,*) "IRECV ended"
6003 c      call flush(iout)
6004 C Send the number of contacts needed by other processors
6005       do ii=1,ntask_cont_to
6006         iproc=itask_cont_to(ii)
6007         ireq=ireq+1
6008         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6009      &    FG_COMM,req(ireq),IERR)
6010       enddo
6011 c      write (iout,*) "ISEND ended"
6012 c      write (iout,*) "number of requests (nn)",ireq
6013       call flush(iout)
6014       if (ireq.gt.0)
6015      &  call MPI_Waitall(ireq,req,status_array,ierr)
6016 c      write (iout,*)
6017 c     &  "Numbers of contacts to be received from other processors",
6018 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6019 c      call flush(iout)
6020 C Receive contacts
6021       ireq=0
6022       do ii=1,ntask_cont_from
6023         iproc=itask_cont_from(ii)
6024         nn=ncont_recv(ii)
6025 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6026 c     &   " of CONT_TO_COMM group"
6027         call flush(iout)
6028         if (nn.gt.0) then
6029           ireq=ireq+1
6030           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6031      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6032 c          write (iout,*) "ireq,req",ireq,req(ireq)
6033         endif
6034       enddo
6035 C Send the contacts to processors that need them
6036       do ii=1,ntask_cont_to
6037         iproc=itask_cont_to(ii)
6038         nn=ncont_sent(ii)
6039 c        write (iout,*) nn," contacts to processor",iproc,
6040 c     &   " of CONT_TO_COMM group"
6041         if (nn.gt.0) then
6042           ireq=ireq+1
6043           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6044      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6045 c          write (iout,*) "ireq,req",ireq,req(ireq)
6046 c          do i=1,nn
6047 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6048 c          enddo
6049         endif
6050       enddo
6051 c      write (iout,*) "number of requests (contacts)",ireq
6052 c      write (iout,*) "req",(req(i),i=1,4)
6053 c      call flush(iout)
6054       if (ireq.gt.0)
6055      & call MPI_Waitall(ireq,req,status_array,ierr)
6056       do iii=1,ntask_cont_from
6057         iproc=itask_cont_from(iii)
6058         nn=ncont_recv(iii)
6059         if (lprn) then
6060         write (iout,*) "Received",nn," contacts from processor",iproc,
6061      &   " of CONT_FROM_COMM group"
6062         call flush(iout)
6063         do i=1,nn
6064           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6065         enddo
6066         call flush(iout)
6067         endif
6068         do i=1,nn
6069           ii=zapas_recv(1,i,iii)
6070 c Flag the received contacts to prevent double-counting
6071           jj=-zapas_recv(2,i,iii)
6072 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6073 c          call flush(iout)
6074           nnn=num_cont_hb(ii)+1
6075           num_cont_hb(ii)=nnn
6076           jcont_hb(nnn,ii)=jj
6077           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6078           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6079           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6080           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6081           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6082           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6083           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6084           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6085           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6086           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6087           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6088           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6089           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6090           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6091           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6092           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6093           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6094           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6095           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6096           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6097           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6098           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6099           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6100           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6101         enddo
6102       enddo
6103       call flush(iout)
6104       if (lprn) then
6105         write (iout,'(a)') 'Contact function values after receive:'
6106         do i=nnt,nct-2
6107           write (iout,'(2i3,50(1x,i3,f5.2))')
6108      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6109      &    j=1,num_cont_hb(i))
6110         enddo
6111         call flush(iout)
6112       endif
6113    30 continue
6114 #endif
6115       if (lprn) then
6116         write (iout,'(a)') 'Contact function values:'
6117         do i=nnt,nct-2
6118           write (iout,'(2i3,50(1x,i3,f5.2))')
6119      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6120      &    j=1,num_cont_hb(i))
6121         enddo
6122       endif
6123       ecorr=0.0D0
6124 C Remove the loop below after debugging !!!
6125       do i=nnt,nct
6126         do j=1,3
6127           gradcorr(j,i)=0.0D0
6128           gradxorr(j,i)=0.0D0
6129         enddo
6130       enddo
6131 C Calculate the local-electrostatic correlation terms
6132       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6133         i1=i+1
6134         num_conti=num_cont_hb(i)
6135         num_conti1=num_cont_hb(i+1)
6136         do jj=1,num_conti
6137           j=jcont_hb(jj,i)
6138           jp=iabs(j)
6139           do kk=1,num_conti1
6140             j1=jcont_hb(kk,i1)
6141             jp1=iabs(j1)
6142 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6143 c     &         ' jj=',jj,' kk=',kk
6144             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6145      &          .or. j.lt.0 .and. j1.gt.0) .and.
6146      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6147 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6148 C The system gains extra energy.
6149               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6150               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6151      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6152               n_corr=n_corr+1
6153             else if (j1.eq.j) then
6154 C Contacts I-J and I-(J+1) occur simultaneously.
6155 C The system loses extra energy.
6156 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6157             endif
6158           enddo ! kk
6159           do kk=1,num_conti
6160             j1=jcont_hb(kk,i)
6161 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6162 c    &         ' jj=',jj,' kk=',kk
6163             if (j1.eq.j+1) then
6164 C Contacts I-J and (I+1)-J occur simultaneously.
6165 C The system loses extra energy.
6166 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6167             endif ! j1==j+1
6168           enddo ! kk
6169         enddo ! jj
6170       enddo ! i
6171       return
6172       end
6173 c------------------------------------------------------------------------------
6174       subroutine add_hb_contact(ii,jj,itask)
6175       implicit real*8 (a-h,o-z)
6176       include "DIMENSIONS"
6177       include "COMMON.IOUNITS"
6178       integer max_cont
6179       integer max_dim
6180       parameter (max_cont=maxconts)
6181       parameter (max_dim=26)
6182       include "COMMON.CONTACTS"
6183       double precision zapas(max_dim,maxconts,max_fg_procs),
6184      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6185       common /przechowalnia/ zapas
6186       integer i,j,ii,jj,iproc,itask(4),nn
6187 c      write (iout,*) "itask",itask
6188       do i=1,2
6189         iproc=itask(i)
6190         if (iproc.gt.0) then
6191           do j=1,num_cont_hb(ii)
6192             jjc=jcont_hb(j,ii)
6193 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6194             if (jjc.eq.jj) then
6195               ncont_sent(iproc)=ncont_sent(iproc)+1
6196               nn=ncont_sent(iproc)
6197               zapas(1,nn,iproc)=ii
6198               zapas(2,nn,iproc)=jjc
6199               zapas(3,nn,iproc)=facont_hb(j,ii)
6200               zapas(4,nn,iproc)=ees0p(j,ii)
6201               zapas(5,nn,iproc)=ees0m(j,ii)
6202               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6203               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6204               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6205               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6206               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6207               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6208               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6209               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6210               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6211               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6212               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6213               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6214               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6215               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6216               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6217               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6218               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6219               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6220               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6221               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6222               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6223               exit
6224             endif
6225           enddo
6226         endif
6227       enddo
6228       return
6229       end
6230 c------------------------------------------------------------------------------
6231       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6232      &  n_corr1)
6233 C This subroutine calculates multi-body contributions to hydrogen-bonding
6234       implicit real*8 (a-h,o-z)
6235       include 'DIMENSIONS'
6236       include 'COMMON.IOUNITS'
6237 #ifdef MPI
6238       include "mpif.h"
6239       parameter (max_cont=maxconts)
6240       parameter (max_dim=70)
6241       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6242       double precision zapas(max_dim,maxconts,max_fg_procs),
6243      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6244       common /przechowalnia/ zapas
6245       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6246      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6247 #endif
6248       include 'COMMON.SETUP'
6249       include 'COMMON.FFIELD'
6250       include 'COMMON.DERIV'
6251       include 'COMMON.LOCAL'
6252       include 'COMMON.INTERACT'
6253       include 'COMMON.CONTACTS'
6254       include 'COMMON.CHAIN'
6255       include 'COMMON.CONTROL'
6256       double precision gx(3),gx1(3)
6257       integer num_cont_hb_old(maxres)
6258       logical lprn,ldone
6259       double precision eello4,eello5,eelo6,eello_turn6
6260       external eello4,eello5,eello6,eello_turn6
6261 C Set lprn=.true. for debugging
6262       lprn=.false.
6263       eturn6=0.0d0
6264 #ifdef MPI
6265       do i=1,nres
6266         num_cont_hb_old(i)=num_cont_hb(i)
6267       enddo
6268       n_corr=0
6269       n_corr1=0
6270       if (nfgtasks.le.1) goto 30
6271       if (lprn) then
6272         write (iout,'(a)') 'Contact function values before RECEIVE:'
6273         do i=nnt,nct-2
6274           write (iout,'(2i3,50(1x,i2,f5.2))')
6275      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6276      &    j=1,num_cont_hb(i))
6277         enddo
6278       endif
6279       call flush(iout)
6280       do i=1,ntask_cont_from
6281         ncont_recv(i)=0
6282       enddo
6283       do i=1,ntask_cont_to
6284         ncont_sent(i)=0
6285       enddo
6286 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6287 c     & ntask_cont_to
6288 C Make the list of contacts to send to send to other procesors
6289       do i=iturn3_start,iturn3_end
6290 c        write (iout,*) "make contact list turn3",i," num_cont",
6291 c     &    num_cont_hb(i)
6292         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6293       enddo
6294       do i=iturn4_start,iturn4_end
6295 c        write (iout,*) "make contact list turn4",i," num_cont",
6296 c     &   num_cont_hb(i)
6297         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6298       enddo
6299       do ii=1,nat_sent
6300         i=iat_sent(ii)
6301 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6302 c     &    num_cont_hb(i)
6303         do j=1,num_cont_hb(i)
6304         do k=1,4
6305           jjc=jcont_hb(j,i)
6306           iproc=iint_sent_local(k,jjc,ii)
6307 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6308           if (iproc.ne.0) then
6309             ncont_sent(iproc)=ncont_sent(iproc)+1
6310             nn=ncont_sent(iproc)
6311             zapas(1,nn,iproc)=i
6312             zapas(2,nn,iproc)=jjc
6313             zapas(3,nn,iproc)=d_cont(j,i)
6314             ind=3
6315             do kk=1,3
6316               ind=ind+1
6317               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6318             enddo
6319             do kk=1,2
6320               do ll=1,2
6321                 ind=ind+1
6322                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6323               enddo
6324             enddo
6325             do jj=1,5
6326               do kk=1,3
6327                 do ll=1,2
6328                   do mm=1,2
6329                     ind=ind+1
6330                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6331                   enddo
6332                 enddo
6333               enddo
6334             enddo
6335           endif
6336         enddo
6337         enddo
6338       enddo
6339       if (lprn) then
6340       write (iout,*)
6341      &  "Numbers of contacts to be sent to other processors",
6342      &  (ncont_sent(i),i=1,ntask_cont_to)
6343       write (iout,*) "Contacts sent"
6344       do ii=1,ntask_cont_to
6345         nn=ncont_sent(ii)
6346         iproc=itask_cont_to(ii)
6347         write (iout,*) nn," contacts to processor",iproc,
6348      &   " of CONT_TO_COMM group"
6349         do i=1,nn
6350           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6351         enddo
6352       enddo
6353       call flush(iout)
6354       endif
6355       CorrelType=477
6356       CorrelID=fg_rank+1
6357       CorrelType1=478
6358       CorrelID1=nfgtasks+fg_rank+1
6359       ireq=0
6360 C Receive the numbers of needed contacts from other processors
6361       do ii=1,ntask_cont_from
6362         iproc=itask_cont_from(ii)
6363         ireq=ireq+1
6364         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6365      &    FG_COMM,req(ireq),IERR)
6366       enddo
6367 c      write (iout,*) "IRECV ended"
6368 c      call flush(iout)
6369 C Send the number of contacts needed by other processors
6370       do ii=1,ntask_cont_to
6371         iproc=itask_cont_to(ii)
6372         ireq=ireq+1
6373         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6374      &    FG_COMM,req(ireq),IERR)
6375       enddo
6376 c      write (iout,*) "ISEND ended"
6377 c      write (iout,*) "number of requests (nn)",ireq
6378       call flush(iout)
6379       if (ireq.gt.0)
6380      &  call MPI_Waitall(ireq,req,status_array,ierr)
6381 c      write (iout,*)
6382 c     &  "Numbers of contacts to be received from other processors",
6383 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6384 c      call flush(iout)
6385 C Receive contacts
6386       ireq=0
6387       do ii=1,ntask_cont_from
6388         iproc=itask_cont_from(ii)
6389         nn=ncont_recv(ii)
6390 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6391 c     &   " of CONT_TO_COMM group"
6392         call flush(iout)
6393         if (nn.gt.0) then
6394           ireq=ireq+1
6395           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6396      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6397 c          write (iout,*) "ireq,req",ireq,req(ireq)
6398         endif
6399       enddo
6400 C Send the contacts to processors that need them
6401       do ii=1,ntask_cont_to
6402         iproc=itask_cont_to(ii)
6403         nn=ncont_sent(ii)
6404 c        write (iout,*) nn," contacts to processor",iproc,
6405 c     &   " of CONT_TO_COMM group"
6406         if (nn.gt.0) then
6407           ireq=ireq+1
6408           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6409      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6410 c          write (iout,*) "ireq,req",ireq,req(ireq)
6411 c          do i=1,nn
6412 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6413 c          enddo
6414         endif
6415       enddo
6416 c      write (iout,*) "number of requests (contacts)",ireq
6417 c      write (iout,*) "req",(req(i),i=1,4)
6418 c      call flush(iout)
6419       if (ireq.gt.0)
6420      & call MPI_Waitall(ireq,req,status_array,ierr)
6421       do iii=1,ntask_cont_from
6422         iproc=itask_cont_from(iii)
6423         nn=ncont_recv(iii)
6424         if (lprn) then
6425         write (iout,*) "Received",nn," contacts from processor",iproc,
6426      &   " of CONT_FROM_COMM group"
6427         call flush(iout)
6428         do i=1,nn
6429           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6430         enddo
6431         call flush(iout)
6432         endif
6433         do i=1,nn
6434           ii=zapas_recv(1,i,iii)
6435 c Flag the received contacts to prevent double-counting
6436           jj=-zapas_recv(2,i,iii)
6437 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6438 c          call flush(iout)
6439           nnn=num_cont_hb(ii)+1
6440           num_cont_hb(ii)=nnn
6441           jcont_hb(nnn,ii)=jj
6442           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6443           ind=3
6444           do kk=1,3
6445             ind=ind+1
6446             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6447           enddo
6448           do kk=1,2
6449             do ll=1,2
6450               ind=ind+1
6451               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6452             enddo
6453           enddo
6454           do jj=1,5
6455             do kk=1,3
6456               do ll=1,2
6457                 do mm=1,2
6458                   ind=ind+1
6459                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6460                 enddo
6461               enddo
6462             enddo
6463           enddo
6464         enddo
6465       enddo
6466       call flush(iout)
6467       if (lprn) then
6468         write (iout,'(a)') 'Contact function values after receive:'
6469         do i=nnt,nct-2
6470           write (iout,'(2i3,50(1x,i3,5f6.3))')
6471      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6472      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6473         enddo
6474         call flush(iout)
6475       endif
6476    30 continue
6477 #endif
6478       if (lprn) then
6479         write (iout,'(a)') 'Contact function values:'
6480         do i=nnt,nct-2
6481           write (iout,'(2i3,50(1x,i2,5f6.3))')
6482      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6483      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6484         enddo
6485       endif
6486       ecorr=0.0D0
6487       ecorr5=0.0d0
6488       ecorr6=0.0d0
6489 C Remove the loop below after debugging !!!
6490       do i=nnt,nct
6491         do j=1,3
6492           gradcorr(j,i)=0.0D0
6493           gradxorr(j,i)=0.0D0
6494         enddo
6495       enddo
6496 C Calculate the dipole-dipole interaction energies
6497       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6498       do i=iatel_s,iatel_e+1
6499         num_conti=num_cont_hb(i)
6500         do jj=1,num_conti
6501           j=jcont_hb(jj,i)
6502 #ifdef MOMENT
6503           call dipole(i,j,jj)
6504 #endif
6505         enddo
6506       enddo
6507       endif
6508 C Calculate the local-electrostatic correlation terms
6509 c                write (iout,*) "gradcorr5 in eello5 before loop"
6510 c                do iii=1,nres
6511 c                  write (iout,'(i5,3f10.5)')
6512 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6513 c                enddo
6514       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6515 c        write (iout,*) "corr loop i",i
6516         i1=i+1
6517         num_conti=num_cont_hb(i)
6518         num_conti1=num_cont_hb(i+1)
6519         do jj=1,num_conti
6520           j=jcont_hb(jj,i)
6521           jp=iabs(j)
6522           do kk=1,num_conti1
6523             j1=jcont_hb(kk,i1)
6524             jp1=iabs(j1)
6525 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6526 c     &         ' jj=',jj,' kk=',kk
6527 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6528             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6529      &          .or. j.lt.0 .and. j1.gt.0) .and.
6530      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6531 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6532 C The system gains extra energy.
6533               n_corr=n_corr+1
6534               sqd1=dsqrt(d_cont(jj,i))
6535               sqd2=dsqrt(d_cont(kk,i1))
6536               sred_geom = sqd1*sqd2
6537               IF (sred_geom.lt.cutoff_corr) THEN
6538                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6539      &            ekont,fprimcont)
6540 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6541 cd     &         ' jj=',jj,' kk=',kk
6542                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6543                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6544                 do l=1,3
6545                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6546                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6547                 enddo
6548                 n_corr1=n_corr1+1
6549 cd               write (iout,*) 'sred_geom=',sred_geom,
6550 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6551 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6552 cd               write (iout,*) "g_contij",g_contij
6553 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6554 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6555                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6556                 if (wcorr4.gt.0.0d0)
6557      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6558                   if (energy_dec.and.wcorr4.gt.0.0d0)
6559      1                 write (iout,'(a6,4i5,0pf7.3)')
6560      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6561 c                write (iout,*) "gradcorr5 before eello5"
6562 c                do iii=1,nres
6563 c                  write (iout,'(i5,3f10.5)')
6564 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6565 c                enddo
6566                 if (wcorr5.gt.0.0d0)
6567      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6568 c                write (iout,*) "gradcorr5 after eello5"
6569 c                do iii=1,nres
6570 c                  write (iout,'(i5,3f10.5)')
6571 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6572 c                enddo
6573                   if (energy_dec.and.wcorr5.gt.0.0d0)
6574      1                 write (iout,'(a6,4i5,0pf7.3)')
6575      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6576 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6577 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6578                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6579      &               .or. wturn6.eq.0.0d0))then
6580 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6581                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6582                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6583      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6584 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6585 cd     &            'ecorr6=',ecorr6
6586 cd                write (iout,'(4e15.5)') sred_geom,
6587 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6588 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6589 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6590                 else if (wturn6.gt.0.0d0
6591      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6592 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6593                   eturn6=eturn6+eello_turn6(i,jj,kk)
6594                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6595      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6596 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6597                 endif
6598               ENDIF
6599 1111          continue
6600             endif
6601           enddo ! kk
6602         enddo ! jj
6603       enddo ! i
6604       do i=1,nres
6605         num_cont_hb(i)=num_cont_hb_old(i)
6606       enddo
6607 c                write (iout,*) "gradcorr5 in eello5"
6608 c                do iii=1,nres
6609 c                  write (iout,'(i5,3f10.5)')
6610 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6611 c                enddo
6612       return
6613       end
6614 c------------------------------------------------------------------------------
6615       subroutine add_hb_contact_eello(ii,jj,itask)
6616       implicit real*8 (a-h,o-z)
6617       include "DIMENSIONS"
6618       include "COMMON.IOUNITS"
6619       integer max_cont
6620       integer max_dim
6621       parameter (max_cont=maxconts)
6622       parameter (max_dim=70)
6623       include "COMMON.CONTACTS"
6624       double precision zapas(max_dim,maxconts,max_fg_procs),
6625      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6626       common /przechowalnia/ zapas
6627       integer i,j,ii,jj,iproc,itask(4),nn
6628 c      write (iout,*) "itask",itask
6629       do i=1,2
6630         iproc=itask(i)
6631         if (iproc.gt.0) then
6632           do j=1,num_cont_hb(ii)
6633             jjc=jcont_hb(j,ii)
6634 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6635             if (jjc.eq.jj) then
6636               ncont_sent(iproc)=ncont_sent(iproc)+1
6637               nn=ncont_sent(iproc)
6638               zapas(1,nn,iproc)=ii
6639               zapas(2,nn,iproc)=jjc
6640               zapas(3,nn,iproc)=d_cont(j,ii)
6641               ind=3
6642               do kk=1,3
6643                 ind=ind+1
6644                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6645               enddo
6646               do kk=1,2
6647                 do ll=1,2
6648                   ind=ind+1
6649                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6650                 enddo
6651               enddo
6652               do jj=1,5
6653                 do kk=1,3
6654                   do ll=1,2
6655                     do mm=1,2
6656                       ind=ind+1
6657                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6658                     enddo
6659                   enddo
6660                 enddo
6661               enddo
6662               exit
6663             endif
6664           enddo
6665         endif
6666       enddo
6667       return
6668       end
6669 c------------------------------------------------------------------------------
6670       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6671       implicit real*8 (a-h,o-z)
6672       include 'DIMENSIONS'
6673       include 'COMMON.IOUNITS'
6674       include 'COMMON.DERIV'
6675       include 'COMMON.INTERACT'
6676       include 'COMMON.CONTACTS'
6677       double precision gx(3),gx1(3)
6678       logical lprn
6679       lprn=.false.
6680       eij=facont_hb(jj,i)
6681       ekl=facont_hb(kk,k)
6682       ees0pij=ees0p(jj,i)
6683       ees0pkl=ees0p(kk,k)
6684       ees0mij=ees0m(jj,i)
6685       ees0mkl=ees0m(kk,k)
6686       ekont=eij*ekl
6687       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6688 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6689 C Following 4 lines for diagnostics.
6690 cd    ees0pkl=0.0D0
6691 cd    ees0pij=1.0D0
6692 cd    ees0mkl=0.0D0
6693 cd    ees0mij=1.0D0
6694 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6695 c     & 'Contacts ',i,j,
6696 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6697 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6698 c     & 'gradcorr_long'
6699 C Calculate the multi-body contribution to energy.
6700 c      ecorr=ecorr+ekont*ees
6701 C Calculate multi-body contributions to the gradient.
6702       coeffpees0pij=coeffp*ees0pij
6703       coeffmees0mij=coeffm*ees0mij
6704       coeffpees0pkl=coeffp*ees0pkl
6705       coeffmees0mkl=coeffm*ees0mkl
6706       do ll=1,3
6707 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6708         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6709      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6710      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6711         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6712      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6713      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6714 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6715         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6716      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6717      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6718         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6719      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6720      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6721         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6722      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6723      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6724         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6725         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6726         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6727      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6728      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6729         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6730         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6731 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6732       enddo
6733 c      write (iout,*)
6734 cgrad      do m=i+1,j-1
6735 cgrad        do ll=1,3
6736 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6737 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6738 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6739 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6740 cgrad        enddo
6741 cgrad      enddo
6742 cgrad      do m=k+1,l-1
6743 cgrad        do ll=1,3
6744 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6745 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6746 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6747 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6748 cgrad        enddo
6749 cgrad      enddo
6750 c      write (iout,*) "ehbcorr",ekont*ees
6751       ehbcorr=ekont*ees
6752       return
6753       end
6754 #ifdef MOMENT
6755 C---------------------------------------------------------------------------
6756       subroutine dipole(i,j,jj)
6757       implicit real*8 (a-h,o-z)
6758       include 'DIMENSIONS'
6759       include 'COMMON.IOUNITS'
6760       include 'COMMON.CHAIN'
6761       include 'COMMON.FFIELD'
6762       include 'COMMON.DERIV'
6763       include 'COMMON.INTERACT'
6764       include 'COMMON.CONTACTS'
6765       include 'COMMON.TORSION'
6766       include 'COMMON.VAR'
6767       include 'COMMON.GEO'
6768       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6769      &  auxmat(2,2)
6770       iti1 = itortyp(itype(i+1))
6771       if (j.lt.nres-1) then
6772         itj1 = itortyp(itype(j+1))
6773       else
6774         itj1=ntortyp+1
6775       endif
6776       do iii=1,2
6777         dipi(iii,1)=Ub2(iii,i)
6778         dipderi(iii)=Ub2der(iii,i)
6779         dipi(iii,2)=b1(iii,iti1)
6780         dipj(iii,1)=Ub2(iii,j)
6781         dipderj(iii)=Ub2der(iii,j)
6782         dipj(iii,2)=b1(iii,itj1)
6783       enddo
6784       kkk=0
6785       do iii=1,2
6786         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6787         do jjj=1,2
6788           kkk=kkk+1
6789           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6790         enddo
6791       enddo
6792       do kkk=1,5
6793         do lll=1,3
6794           mmm=0
6795           do iii=1,2
6796             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6797      &        auxvec(1))
6798             do jjj=1,2
6799               mmm=mmm+1
6800               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6801             enddo
6802           enddo
6803         enddo
6804       enddo
6805       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6806       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6807       do iii=1,2
6808         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6809       enddo
6810       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6811       do iii=1,2
6812         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6813       enddo
6814       return
6815       end
6816 #endif
6817 C---------------------------------------------------------------------------
6818       subroutine calc_eello(i,j,k,l,jj,kk)
6819 C
6820 C This subroutine computes matrices and vectors needed to calculate
6821 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6822 C
6823       implicit real*8 (a-h,o-z)
6824       include 'DIMENSIONS'
6825       include 'COMMON.IOUNITS'
6826       include 'COMMON.CHAIN'
6827       include 'COMMON.DERIV'
6828       include 'COMMON.INTERACT'
6829       include 'COMMON.CONTACTS'
6830       include 'COMMON.TORSION'
6831       include 'COMMON.VAR'
6832       include 'COMMON.GEO'
6833       include 'COMMON.FFIELD'
6834       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6835      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6836       logical lprn
6837       common /kutas/ lprn
6838 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6839 cd     & ' jj=',jj,' kk=',kk
6840 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6841 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6842 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6843       do iii=1,2
6844         do jjj=1,2
6845           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6846           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6847         enddo
6848       enddo
6849       call transpose2(aa1(1,1),aa1t(1,1))
6850       call transpose2(aa2(1,1),aa2t(1,1))
6851       do kkk=1,5
6852         do lll=1,3
6853           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6854      &      aa1tder(1,1,lll,kkk))
6855           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6856      &      aa2tder(1,1,lll,kkk))
6857         enddo
6858       enddo
6859       if (l.eq.j+1) then
6860 C parallel orientation of the two CA-CA-CA frames.
6861         if (i.gt.1) then
6862           iti=itortyp(itype(i))
6863         else
6864           iti=ntortyp+1
6865         endif
6866         itk1=itortyp(itype(k+1))
6867         itj=itortyp(itype(j))
6868         if (l.lt.nres-1) then
6869           itl1=itortyp(itype(l+1))
6870         else
6871           itl1=ntortyp+1
6872         endif
6873 C A1 kernel(j+1) A2T
6874 cd        do iii=1,2
6875 cd          write (iout,'(3f10.5,5x,3f10.5)')
6876 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6877 cd        enddo
6878         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6879      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6880      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6881 C Following matrices are needed only for 6-th order cumulants
6882         IF (wcorr6.gt.0.0d0) THEN
6883         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6884      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6885      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6886         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6887      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6888      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6889      &   ADtEAderx(1,1,1,1,1,1))
6890         lprn=.false.
6891         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6892      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6893      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6894      &   ADtEA1derx(1,1,1,1,1,1))
6895         ENDIF
6896 C End 6-th order cumulants
6897 cd        lprn=.false.
6898 cd        if (lprn) then
6899 cd        write (2,*) 'In calc_eello6'
6900 cd        do iii=1,2
6901 cd          write (2,*) 'iii=',iii
6902 cd          do kkk=1,5
6903 cd            write (2,*) 'kkk=',kkk
6904 cd            do jjj=1,2
6905 cd              write (2,'(3(2f10.5),5x)')
6906 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6907 cd            enddo
6908 cd          enddo
6909 cd        enddo
6910 cd        endif
6911         call transpose2(EUgder(1,1,k),auxmat(1,1))
6912         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6913         call transpose2(EUg(1,1,k),auxmat(1,1))
6914         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6915         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6916         do iii=1,2
6917           do kkk=1,5
6918             do lll=1,3
6919               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6920      &          EAEAderx(1,1,lll,kkk,iii,1))
6921             enddo
6922           enddo
6923         enddo
6924 C A1T kernel(i+1) A2
6925         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6926      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6927      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6928 C Following matrices are needed only for 6-th order cumulants
6929         IF (wcorr6.gt.0.0d0) THEN
6930         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6931      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6932      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6933         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6934      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6935      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6936      &   ADtEAderx(1,1,1,1,1,2))
6937         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6938      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6939      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6940      &   ADtEA1derx(1,1,1,1,1,2))
6941         ENDIF
6942 C End 6-th order cumulants
6943         call transpose2(EUgder(1,1,l),auxmat(1,1))
6944         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6945         call transpose2(EUg(1,1,l),auxmat(1,1))
6946         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6947         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6948         do iii=1,2
6949           do kkk=1,5
6950             do lll=1,3
6951               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6952      &          EAEAderx(1,1,lll,kkk,iii,2))
6953             enddo
6954           enddo
6955         enddo
6956 C AEAb1 and AEAb2
6957 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6958 C They are needed only when the fifth- or the sixth-order cumulants are
6959 C indluded.
6960         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6961         call transpose2(AEA(1,1,1),auxmat(1,1))
6962         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6963         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6964         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6965         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6966         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6967         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6968         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6969         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6970         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6971         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6972         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6973         call transpose2(AEA(1,1,2),auxmat(1,1))
6974         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6975         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6976         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6977         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6978         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6979         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6980         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6981         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6982         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6983         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6984         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6985 C Calculate the Cartesian derivatives of the vectors.
6986         do iii=1,2
6987           do kkk=1,5
6988             do lll=1,3
6989               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6990               call matvec2(auxmat(1,1),b1(1,iti),
6991      &          AEAb1derx(1,lll,kkk,iii,1,1))
6992               call matvec2(auxmat(1,1),Ub2(1,i),
6993      &          AEAb2derx(1,lll,kkk,iii,1,1))
6994               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6995      &          AEAb1derx(1,lll,kkk,iii,2,1))
6996               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6997      &          AEAb2derx(1,lll,kkk,iii,2,1))
6998               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6999               call matvec2(auxmat(1,1),b1(1,itj),
7000      &          AEAb1derx(1,lll,kkk,iii,1,2))
7001               call matvec2(auxmat(1,1),Ub2(1,j),
7002      &          AEAb2derx(1,lll,kkk,iii,1,2))
7003               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7004      &          AEAb1derx(1,lll,kkk,iii,2,2))
7005               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7006      &          AEAb2derx(1,lll,kkk,iii,2,2))
7007             enddo
7008           enddo
7009         enddo
7010         ENDIF
7011 C End vectors
7012       else
7013 C Antiparallel orientation of the two CA-CA-CA frames.
7014         if (i.gt.1) then
7015           iti=itortyp(itype(i))
7016         else
7017           iti=ntortyp+1
7018         endif
7019         itk1=itortyp(itype(k+1))
7020         itl=itortyp(itype(l))
7021         itj=itortyp(itype(j))
7022         if (j.lt.nres-1) then
7023           itj1=itortyp(itype(j+1))
7024         else
7025           itj1=ntortyp+1
7026         endif
7027 C A2 kernel(j-1)T A1T
7028         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7029      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7030      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7031 C Following matrices are needed only for 6-th order cumulants
7032         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7033      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7034         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7035      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7036      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7037         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7038      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7039      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7040      &   ADtEAderx(1,1,1,1,1,1))
7041         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7042      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7043      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7044      &   ADtEA1derx(1,1,1,1,1,1))
7045         ENDIF
7046 C End 6-th order cumulants
7047         call transpose2(EUgder(1,1,k),auxmat(1,1))
7048         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7049         call transpose2(EUg(1,1,k),auxmat(1,1))
7050         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7051         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7052         do iii=1,2
7053           do kkk=1,5
7054             do lll=1,3
7055               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7056      &          EAEAderx(1,1,lll,kkk,iii,1))
7057             enddo
7058           enddo
7059         enddo
7060 C A2T kernel(i+1)T A1
7061         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7062      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7063      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7064 C Following matrices are needed only for 6-th order cumulants
7065         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7066      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7067         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7068      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7069      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7070         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7071      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7072      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7073      &   ADtEAderx(1,1,1,1,1,2))
7074         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7075      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7076      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7077      &   ADtEA1derx(1,1,1,1,1,2))
7078         ENDIF
7079 C End 6-th order cumulants
7080         call transpose2(EUgder(1,1,j),auxmat(1,1))
7081         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7082         call transpose2(EUg(1,1,j),auxmat(1,1))
7083         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7084         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7085         do iii=1,2
7086           do kkk=1,5
7087             do lll=1,3
7088               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7089      &          EAEAderx(1,1,lll,kkk,iii,2))
7090             enddo
7091           enddo
7092         enddo
7093 C AEAb1 and AEAb2
7094 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7095 C They are needed only when the fifth- or the sixth-order cumulants are
7096 C indluded.
7097         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7098      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7099         call transpose2(AEA(1,1,1),auxmat(1,1))
7100         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7101         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7102         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7103         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7104         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7105         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7106         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7107         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7108         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7109         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7110         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7111         call transpose2(AEA(1,1,2),auxmat(1,1))
7112         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7113         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7114         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7115         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7116         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7117         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7118         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7119         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7120         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7121         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7122         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7123 C Calculate the Cartesian derivatives of the vectors.
7124         do iii=1,2
7125           do kkk=1,5
7126             do lll=1,3
7127               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7128               call matvec2(auxmat(1,1),b1(1,iti),
7129      &          AEAb1derx(1,lll,kkk,iii,1,1))
7130               call matvec2(auxmat(1,1),Ub2(1,i),
7131      &          AEAb2derx(1,lll,kkk,iii,1,1))
7132               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7133      &          AEAb1derx(1,lll,kkk,iii,2,1))
7134               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7135      &          AEAb2derx(1,lll,kkk,iii,2,1))
7136               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7137               call matvec2(auxmat(1,1),b1(1,itl),
7138      &          AEAb1derx(1,lll,kkk,iii,1,2))
7139               call matvec2(auxmat(1,1),Ub2(1,l),
7140      &          AEAb2derx(1,lll,kkk,iii,1,2))
7141               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7142      &          AEAb1derx(1,lll,kkk,iii,2,2))
7143               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7144      &          AEAb2derx(1,lll,kkk,iii,2,2))
7145             enddo
7146           enddo
7147         enddo
7148         ENDIF
7149 C End vectors
7150       endif
7151       return
7152       end
7153 C---------------------------------------------------------------------------
7154       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7155      &  KK,KKderg,AKA,AKAderg,AKAderx)
7156       implicit none
7157       integer nderg
7158       logical transp
7159       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7160      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7161      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7162       integer iii,kkk,lll
7163       integer jjj,mmm
7164       logical lprn
7165       common /kutas/ lprn
7166       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7167       do iii=1,nderg
7168         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7169      &    AKAderg(1,1,iii))
7170       enddo
7171 cd      if (lprn) write (2,*) 'In kernel'
7172       do kkk=1,5
7173 cd        if (lprn) write (2,*) 'kkk=',kkk
7174         do lll=1,3
7175           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7176      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7177 cd          if (lprn) then
7178 cd            write (2,*) 'lll=',lll
7179 cd            write (2,*) 'iii=1'
7180 cd            do jjj=1,2
7181 cd              write (2,'(3(2f10.5),5x)')
7182 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7183 cd            enddo
7184 cd          endif
7185           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7186      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7187 cd          if (lprn) then
7188 cd            write (2,*) 'lll=',lll
7189 cd            write (2,*) 'iii=2'
7190 cd            do jjj=1,2
7191 cd              write (2,'(3(2f10.5),5x)')
7192 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7193 cd            enddo
7194 cd          endif
7195         enddo
7196       enddo
7197       return
7198       end
7199 C---------------------------------------------------------------------------
7200       double precision function eello4(i,j,k,l,jj,kk)
7201       implicit real*8 (a-h,o-z)
7202       include 'DIMENSIONS'
7203       include 'COMMON.IOUNITS'
7204       include 'COMMON.CHAIN'
7205       include 'COMMON.DERIV'
7206       include 'COMMON.INTERACT'
7207       include 'COMMON.CONTACTS'
7208       include 'COMMON.TORSION'
7209       include 'COMMON.VAR'
7210       include 'COMMON.GEO'
7211       double precision pizda(2,2),ggg1(3),ggg2(3)
7212 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7213 cd        eello4=0.0d0
7214 cd        return
7215 cd      endif
7216 cd      print *,'eello4:',i,j,k,l,jj,kk
7217 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7218 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7219 cold      eij=facont_hb(jj,i)
7220 cold      ekl=facont_hb(kk,k)
7221 cold      ekont=eij*ekl
7222       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7223 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7224       gcorr_loc(k-1)=gcorr_loc(k-1)
7225      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7226       if (l.eq.j+1) then
7227         gcorr_loc(l-1)=gcorr_loc(l-1)
7228      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7229       else
7230         gcorr_loc(j-1)=gcorr_loc(j-1)
7231      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7232       endif
7233       do iii=1,2
7234         do kkk=1,5
7235           do lll=1,3
7236             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7237      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7238 cd            derx(lll,kkk,iii)=0.0d0
7239           enddo
7240         enddo
7241       enddo
7242 cd      gcorr_loc(l-1)=0.0d0
7243 cd      gcorr_loc(j-1)=0.0d0
7244 cd      gcorr_loc(k-1)=0.0d0
7245 cd      eel4=1.0d0
7246 cd      write (iout,*)'Contacts have occurred for peptide groups',
7247 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7248 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7249       if (j.lt.nres-1) then
7250         j1=j+1
7251         j2=j-1
7252       else
7253         j1=j-1
7254         j2=j-2
7255       endif
7256       if (l.lt.nres-1) then
7257         l1=l+1
7258         l2=l-1
7259       else
7260         l1=l-1
7261         l2=l-2
7262       endif
7263       do ll=1,3
7264 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7265 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7266         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7267         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7268 cgrad        ghalf=0.5d0*ggg1(ll)
7269         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7270         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7271         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7272         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7273         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7274         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7275 cgrad        ghalf=0.5d0*ggg2(ll)
7276         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7277         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7278         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7279         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7280         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7281         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7282       enddo
7283 cgrad      do m=i+1,j-1
7284 cgrad        do ll=1,3
7285 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7286 cgrad        enddo
7287 cgrad      enddo
7288 cgrad      do m=k+1,l-1
7289 cgrad        do ll=1,3
7290 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7291 cgrad        enddo
7292 cgrad      enddo
7293 cgrad      do m=i+2,j2
7294 cgrad        do ll=1,3
7295 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7296 cgrad        enddo
7297 cgrad      enddo
7298 cgrad      do m=k+2,l2
7299 cgrad        do ll=1,3
7300 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7301 cgrad        enddo
7302 cgrad      enddo
7303 cd      do iii=1,nres-3
7304 cd        write (2,*) iii,gcorr_loc(iii)
7305 cd      enddo
7306       eello4=ekont*eel4
7307 cd      write (2,*) 'ekont',ekont
7308 cd      write (iout,*) 'eello4',ekont*eel4
7309       return
7310       end
7311 C---------------------------------------------------------------------------
7312       double precision function eello5(i,j,k,l,jj,kk)
7313       implicit real*8 (a-h,o-z)
7314       include 'DIMENSIONS'
7315       include 'COMMON.IOUNITS'
7316       include 'COMMON.CHAIN'
7317       include 'COMMON.DERIV'
7318       include 'COMMON.INTERACT'
7319       include 'COMMON.CONTACTS'
7320       include 'COMMON.TORSION'
7321       include 'COMMON.VAR'
7322       include 'COMMON.GEO'
7323       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7324       double precision ggg1(3),ggg2(3)
7325 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7326 C                                                                              C
7327 C                            Parallel chains                                   C
7328 C                                                                              C
7329 C          o             o                   o             o                   C
7330 C         /l\           / \             \   / \           / \   /              C
7331 C        /   \         /   \             \ /   \         /   \ /               C
7332 C       j| o |l1       | o |              o| o |         | o |o                C
7333 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7334 C      \i/   \         /   \ /             /   \         /   \                 C
7335 C       o    k1             o                                                  C
7336 C         (I)          (II)                (III)          (IV)                 C
7337 C                                                                              C
7338 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7339 C                                                                              C
7340 C                            Antiparallel chains                               C
7341 C                                                                              C
7342 C          o             o                   o             o                   C
7343 C         /j\           / \             \   / \           / \   /              C
7344 C        /   \         /   \             \ /   \         /   \ /               C
7345 C      j1| o |l        | o |              o| o |         | o |o                C
7346 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7347 C      \i/   \         /   \ /             /   \         /   \                 C
7348 C       o     k1            o                                                  C
7349 C         (I)          (II)                (III)          (IV)                 C
7350 C                                                                              C
7351 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7352 C                                                                              C
7353 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7354 C                                                                              C
7355 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7356 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7357 cd        eello5=0.0d0
7358 cd        return
7359 cd      endif
7360 cd      write (iout,*)
7361 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7362 cd     &   ' and',k,l
7363       itk=itortyp(itype(k))
7364       itl=itortyp(itype(l))
7365       itj=itortyp(itype(j))
7366       eello5_1=0.0d0
7367       eello5_2=0.0d0
7368       eello5_3=0.0d0
7369       eello5_4=0.0d0
7370 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7371 cd     &   eel5_3_num,eel5_4_num)
7372       do iii=1,2
7373         do kkk=1,5
7374           do lll=1,3
7375             derx(lll,kkk,iii)=0.0d0
7376           enddo
7377         enddo
7378       enddo
7379 cd      eij=facont_hb(jj,i)
7380 cd      ekl=facont_hb(kk,k)
7381 cd      ekont=eij*ekl
7382 cd      write (iout,*)'Contacts have occurred for peptide groups',
7383 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7384 cd      goto 1111
7385 C Contribution from the graph I.
7386 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7387 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7388       call transpose2(EUg(1,1,k),auxmat(1,1))
7389       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7390       vv(1)=pizda(1,1)-pizda(2,2)
7391       vv(2)=pizda(1,2)+pizda(2,1)
7392       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7393      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7394 C Explicit gradient in virtual-dihedral angles.
7395       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7396      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7397      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7398       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7399       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7400       vv(1)=pizda(1,1)-pizda(2,2)
7401       vv(2)=pizda(1,2)+pizda(2,1)
7402       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7403      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7404      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7405       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7406       vv(1)=pizda(1,1)-pizda(2,2)
7407       vv(2)=pizda(1,2)+pizda(2,1)
7408       if (l.eq.j+1) then
7409         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7410      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7411      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7412       else
7413         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7414      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7415      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7416       endif
7417 C Cartesian gradient
7418       do iii=1,2
7419         do kkk=1,5
7420           do lll=1,3
7421             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7422      &        pizda(1,1))
7423             vv(1)=pizda(1,1)-pizda(2,2)
7424             vv(2)=pizda(1,2)+pizda(2,1)
7425             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7426      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7427      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7428           enddo
7429         enddo
7430       enddo
7431 c      goto 1112
7432 c1111  continue
7433 C Contribution from graph II
7434       call transpose2(EE(1,1,itk),auxmat(1,1))
7435       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7436       vv(1)=pizda(1,1)+pizda(2,2)
7437       vv(2)=pizda(2,1)-pizda(1,2)
7438       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7439      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7440 C Explicit gradient in virtual-dihedral angles.
7441       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7442      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7443       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7444       vv(1)=pizda(1,1)+pizda(2,2)
7445       vv(2)=pizda(2,1)-pizda(1,2)
7446       if (l.eq.j+1) then
7447         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7448      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7449      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7450       else
7451         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7452      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7453      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7454       endif
7455 C Cartesian gradient
7456       do iii=1,2
7457         do kkk=1,5
7458           do lll=1,3
7459             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7460      &        pizda(1,1))
7461             vv(1)=pizda(1,1)+pizda(2,2)
7462             vv(2)=pizda(2,1)-pizda(1,2)
7463             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7464      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7465      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7466           enddo
7467         enddo
7468       enddo
7469 cd      goto 1112
7470 cd1111  continue
7471       if (l.eq.j+1) then
7472 cd        goto 1110
7473 C Parallel orientation
7474 C Contribution from graph III
7475         call transpose2(EUg(1,1,l),auxmat(1,1))
7476         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7477         vv(1)=pizda(1,1)-pizda(2,2)
7478         vv(2)=pizda(1,2)+pizda(2,1)
7479         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7480      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7481 C Explicit gradient in virtual-dihedral angles.
7482         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7483      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7484      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7485         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7486         vv(1)=pizda(1,1)-pizda(2,2)
7487         vv(2)=pizda(1,2)+pizda(2,1)
7488         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7489      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7490      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7491         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7492         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7493         vv(1)=pizda(1,1)-pizda(2,2)
7494         vv(2)=pizda(1,2)+pizda(2,1)
7495         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7496      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7497      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7498 C Cartesian gradient
7499         do iii=1,2
7500           do kkk=1,5
7501             do lll=1,3
7502               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7503      &          pizda(1,1))
7504               vv(1)=pizda(1,1)-pizda(2,2)
7505               vv(2)=pizda(1,2)+pizda(2,1)
7506               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7507      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7508      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7509             enddo
7510           enddo
7511         enddo
7512 cd        goto 1112
7513 C Contribution from graph IV
7514 cd1110    continue
7515         call transpose2(EE(1,1,itl),auxmat(1,1))
7516         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7517         vv(1)=pizda(1,1)+pizda(2,2)
7518         vv(2)=pizda(2,1)-pizda(1,2)
7519         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7520      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7521 C Explicit gradient in virtual-dihedral angles.
7522         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7523      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7524         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7525         vv(1)=pizda(1,1)+pizda(2,2)
7526         vv(2)=pizda(2,1)-pizda(1,2)
7527         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7528      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7529      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7530 C Cartesian gradient
7531         do iii=1,2
7532           do kkk=1,5
7533             do lll=1,3
7534               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7535      &          pizda(1,1))
7536               vv(1)=pizda(1,1)+pizda(2,2)
7537               vv(2)=pizda(2,1)-pizda(1,2)
7538               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7539      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7540      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7541             enddo
7542           enddo
7543         enddo
7544       else
7545 C Antiparallel orientation
7546 C Contribution from graph III
7547 c        goto 1110
7548         call transpose2(EUg(1,1,j),auxmat(1,1))
7549         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7550         vv(1)=pizda(1,1)-pizda(2,2)
7551         vv(2)=pizda(1,2)+pizda(2,1)
7552         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7553      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7554 C Explicit gradient in virtual-dihedral angles.
7555         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7556      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7557      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7558         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7559         vv(1)=pizda(1,1)-pizda(2,2)
7560         vv(2)=pizda(1,2)+pizda(2,1)
7561         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7562      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7563      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7564         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7565         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7566         vv(1)=pizda(1,1)-pizda(2,2)
7567         vv(2)=pizda(1,2)+pizda(2,1)
7568         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7569      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7570      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7571 C Cartesian gradient
7572         do iii=1,2
7573           do kkk=1,5
7574             do lll=1,3
7575               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7576      &          pizda(1,1))
7577               vv(1)=pizda(1,1)-pizda(2,2)
7578               vv(2)=pizda(1,2)+pizda(2,1)
7579               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7580      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7581      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7582             enddo
7583           enddo
7584         enddo
7585 cd        goto 1112
7586 C Contribution from graph IV
7587 1110    continue
7588         call transpose2(EE(1,1,itj),auxmat(1,1))
7589         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7590         vv(1)=pizda(1,1)+pizda(2,2)
7591         vv(2)=pizda(2,1)-pizda(1,2)
7592         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7593      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7594 C Explicit gradient in virtual-dihedral angles.
7595         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7596      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7597         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7598         vv(1)=pizda(1,1)+pizda(2,2)
7599         vv(2)=pizda(2,1)-pizda(1,2)
7600         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7601      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7602      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7603 C Cartesian gradient
7604         do iii=1,2
7605           do kkk=1,5
7606             do lll=1,3
7607               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7608      &          pizda(1,1))
7609               vv(1)=pizda(1,1)+pizda(2,2)
7610               vv(2)=pizda(2,1)-pizda(1,2)
7611               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7612      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7613      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7614             enddo
7615           enddo
7616         enddo
7617       endif
7618 1112  continue
7619       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7620 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7621 cd        write (2,*) 'ijkl',i,j,k,l
7622 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7623 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7624 cd      endif
7625 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7626 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7627 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7628 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7629       if (j.lt.nres-1) then
7630         j1=j+1
7631         j2=j-1
7632       else
7633         j1=j-1
7634         j2=j-2
7635       endif
7636       if (l.lt.nres-1) then
7637         l1=l+1
7638         l2=l-1
7639       else
7640         l1=l-1
7641         l2=l-2
7642       endif
7643 cd      eij=1.0d0
7644 cd      ekl=1.0d0
7645 cd      ekont=1.0d0
7646 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7647 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7648 C        summed up outside the subrouine as for the other subroutines
7649 C        handling long-range interactions. The old code is commented out
7650 C        with "cgrad" to keep track of changes.
7651       do ll=1,3
7652 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7653 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7654         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7655         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7656 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7657 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7658 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7659 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7660 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7661 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7662 c     &   gradcorr5ij,
7663 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7664 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7665 cgrad        ghalf=0.5d0*ggg1(ll)
7666 cd        ghalf=0.0d0
7667         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7668         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7669         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7670         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7671         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7672         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7673 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7674 cgrad        ghalf=0.5d0*ggg2(ll)
7675 cd        ghalf=0.0d0
7676         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7677         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7678         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7679         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7680         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7681         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7682       enddo
7683 cd      goto 1112
7684 cgrad      do m=i+1,j-1
7685 cgrad        do ll=1,3
7686 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7687 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7688 cgrad        enddo
7689 cgrad      enddo
7690 cgrad      do m=k+1,l-1
7691 cgrad        do ll=1,3
7692 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7693 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7694 cgrad        enddo
7695 cgrad      enddo
7696 c1112  continue
7697 cgrad      do m=i+2,j2
7698 cgrad        do ll=1,3
7699 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7700 cgrad        enddo
7701 cgrad      enddo
7702 cgrad      do m=k+2,l2
7703 cgrad        do ll=1,3
7704 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7705 cgrad        enddo
7706 cgrad      enddo
7707 cd      do iii=1,nres-3
7708 cd        write (2,*) iii,g_corr5_loc(iii)
7709 cd      enddo
7710       eello5=ekont*eel5
7711 cd      write (2,*) 'ekont',ekont
7712 cd      write (iout,*) 'eello5',ekont*eel5
7713       return
7714       end
7715 c--------------------------------------------------------------------------
7716       double precision function eello6(i,j,k,l,jj,kk)
7717       implicit real*8 (a-h,o-z)
7718       include 'DIMENSIONS'
7719       include 'COMMON.IOUNITS'
7720       include 'COMMON.CHAIN'
7721       include 'COMMON.DERIV'
7722       include 'COMMON.INTERACT'
7723       include 'COMMON.CONTACTS'
7724       include 'COMMON.TORSION'
7725       include 'COMMON.VAR'
7726       include 'COMMON.GEO'
7727       include 'COMMON.FFIELD'
7728       double precision ggg1(3),ggg2(3)
7729 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7730 cd        eello6=0.0d0
7731 cd        return
7732 cd      endif
7733 cd      write (iout,*)
7734 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7735 cd     &   ' and',k,l
7736       eello6_1=0.0d0
7737       eello6_2=0.0d0
7738       eello6_3=0.0d0
7739       eello6_4=0.0d0
7740       eello6_5=0.0d0
7741       eello6_6=0.0d0
7742 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7743 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7744       do iii=1,2
7745         do kkk=1,5
7746           do lll=1,3
7747             derx(lll,kkk,iii)=0.0d0
7748           enddo
7749         enddo
7750       enddo
7751 cd      eij=facont_hb(jj,i)
7752 cd      ekl=facont_hb(kk,k)
7753 cd      ekont=eij*ekl
7754 cd      eij=1.0d0
7755 cd      ekl=1.0d0
7756 cd      ekont=1.0d0
7757       if (l.eq.j+1) then
7758         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7759         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7760         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7761         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7762         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7763         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7764       else
7765         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7766         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7767         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7768         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7769         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7770           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7771         else
7772           eello6_5=0.0d0
7773         endif
7774         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7775       endif
7776 C If turn contributions are considered, they will be handled separately.
7777       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7778 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7779 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7780 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7781 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7782 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7783 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7784 cd      goto 1112
7785       if (j.lt.nres-1) then
7786         j1=j+1
7787         j2=j-1
7788       else
7789         j1=j-1
7790         j2=j-2
7791       endif
7792       if (l.lt.nres-1) then
7793         l1=l+1
7794         l2=l-1
7795       else
7796         l1=l-1
7797         l2=l-2
7798       endif
7799       do ll=1,3
7800 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7801 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7802 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7803 cgrad        ghalf=0.5d0*ggg1(ll)
7804 cd        ghalf=0.0d0
7805         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7806         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7807         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7808         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7809         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7810         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7811         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7812         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7813 cgrad        ghalf=0.5d0*ggg2(ll)
7814 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7815 cd        ghalf=0.0d0
7816         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7817         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7818         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7819         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7820         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7821         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7822       enddo
7823 cd      goto 1112
7824 cgrad      do m=i+1,j-1
7825 cgrad        do ll=1,3
7826 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7827 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7828 cgrad        enddo
7829 cgrad      enddo
7830 cgrad      do m=k+1,l-1
7831 cgrad        do ll=1,3
7832 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7833 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7834 cgrad        enddo
7835 cgrad      enddo
7836 cgrad1112  continue
7837 cgrad      do m=i+2,j2
7838 cgrad        do ll=1,3
7839 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7840 cgrad        enddo
7841 cgrad      enddo
7842 cgrad      do m=k+2,l2
7843 cgrad        do ll=1,3
7844 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7845 cgrad        enddo
7846 cgrad      enddo
7847 cd      do iii=1,nres-3
7848 cd        write (2,*) iii,g_corr6_loc(iii)
7849 cd      enddo
7850       eello6=ekont*eel6
7851 cd      write (2,*) 'ekont',ekont
7852 cd      write (iout,*) 'eello6',ekont*eel6
7853       return
7854       end
7855 c--------------------------------------------------------------------------
7856       double precision function eello6_graph1(i,j,k,l,imat,swap)
7857       implicit real*8 (a-h,o-z)
7858       include 'DIMENSIONS'
7859       include 'COMMON.IOUNITS'
7860       include 'COMMON.CHAIN'
7861       include 'COMMON.DERIV'
7862       include 'COMMON.INTERACT'
7863       include 'COMMON.CONTACTS'
7864       include 'COMMON.TORSION'
7865       include 'COMMON.VAR'
7866       include 'COMMON.GEO'
7867       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7868       logical swap
7869       logical lprn
7870       common /kutas/ lprn
7871 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7872 C                                                                              C
7873 C      Parallel       Antiparallel                                             C
7874 C                                                                              C
7875 C          o             o                                                     C
7876 C         /l\           /j\                                                    C
7877 C        /   \         /   \                                                   C
7878 C       /| o |         | o |\                                                  C
7879 C     \ j|/k\|  /   \  |/k\|l /                                                C
7880 C      \ /   \ /     \ /   \ /                                                 C
7881 C       o     o       o     o                                                  C
7882 C       i             i                                                        C
7883 C                                                                              C
7884 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7885       itk=itortyp(itype(k))
7886       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7887       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7888       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7889       call transpose2(EUgC(1,1,k),auxmat(1,1))
7890       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7891       vv1(1)=pizda1(1,1)-pizda1(2,2)
7892       vv1(2)=pizda1(1,2)+pizda1(2,1)
7893       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7894       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7895       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7896       s5=scalar2(vv(1),Dtobr2(1,i))
7897 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7898       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7899       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7900      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7901      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7902      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7903      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7904      & +scalar2(vv(1),Dtobr2der(1,i)))
7905       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7906       vv1(1)=pizda1(1,1)-pizda1(2,2)
7907       vv1(2)=pizda1(1,2)+pizda1(2,1)
7908       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7909       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7910       if (l.eq.j+1) then
7911         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7912      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7913      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7914      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7915      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7916       else
7917         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7918      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7919      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7920      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7921      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7922       endif
7923       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7924       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7925       vv1(1)=pizda1(1,1)-pizda1(2,2)
7926       vv1(2)=pizda1(1,2)+pizda1(2,1)
7927       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7928      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7929      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7930      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7931       do iii=1,2
7932         if (swap) then
7933           ind=3-iii
7934         else
7935           ind=iii
7936         endif
7937         do kkk=1,5
7938           do lll=1,3
7939             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7940             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7941             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7942             call transpose2(EUgC(1,1,k),auxmat(1,1))
7943             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7944      &        pizda1(1,1))
7945             vv1(1)=pizda1(1,1)-pizda1(2,2)
7946             vv1(2)=pizda1(1,2)+pizda1(2,1)
7947             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7948             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7949      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7950             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7951      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7952             s5=scalar2(vv(1),Dtobr2(1,i))
7953             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7954           enddo
7955         enddo
7956       enddo
7957       return
7958       end
7959 c----------------------------------------------------------------------------
7960       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7961       implicit real*8 (a-h,o-z)
7962       include 'DIMENSIONS'
7963       include 'COMMON.IOUNITS'
7964       include 'COMMON.CHAIN'
7965       include 'COMMON.DERIV'
7966       include 'COMMON.INTERACT'
7967       include 'COMMON.CONTACTS'
7968       include 'COMMON.TORSION'
7969       include 'COMMON.VAR'
7970       include 'COMMON.GEO'
7971       logical swap
7972       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7973      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7974       logical lprn
7975       common /kutas/ lprn
7976 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7977 C                                                                              C
7978 C      Parallel       Antiparallel                                             C
7979 C                                                                              C
7980 C          o             o                                                     C
7981 C     \   /l\           /j\   /                                                C
7982 C      \ /   \         /   \ /                                                 C
7983 C       o| o |         | o |o                                                  C
7984 C     \ j|/k\|      \  |/k\|l                                                  C
7985 C      \ /   \       \ /   \                                                   C
7986 C       o             o                                                        C
7987 C       i             i                                                        C
7988 C                                                                              C
7989 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7990 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7991 C AL 7/4/01 s1 would occur in the sixth-order moment,
7992 C           but not in a cluster cumulant
7993 #ifdef MOMENT
7994       s1=dip(1,jj,i)*dip(1,kk,k)
7995 #endif
7996       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7997       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7998       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7999       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8000       call transpose2(EUg(1,1,k),auxmat(1,1))
8001       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8002       vv(1)=pizda(1,1)-pizda(2,2)
8003       vv(2)=pizda(1,2)+pizda(2,1)
8004       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8005 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8006 #ifdef MOMENT
8007       eello6_graph2=-(s1+s2+s3+s4)
8008 #else
8009       eello6_graph2=-(s2+s3+s4)
8010 #endif
8011 c      eello6_graph2=-s3
8012 C Derivatives in gamma(i-1)
8013       if (i.gt.1) then
8014 #ifdef MOMENT
8015         s1=dipderg(1,jj,i)*dip(1,kk,k)
8016 #endif
8017         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8018         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8019         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8020         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8021 #ifdef MOMENT
8022         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8023 #else
8024         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8025 #endif
8026 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8027       endif
8028 C Derivatives in gamma(k-1)
8029 #ifdef MOMENT
8030       s1=dip(1,jj,i)*dipderg(1,kk,k)
8031 #endif
8032       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8033       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8034       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8035       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8036       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8037       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8038       vv(1)=pizda(1,1)-pizda(2,2)
8039       vv(2)=pizda(1,2)+pizda(2,1)
8040       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8041 #ifdef MOMENT
8042       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8043 #else
8044       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8045 #endif
8046 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8047 C Derivatives in gamma(j-1) or gamma(l-1)
8048       if (j.gt.1) then
8049 #ifdef MOMENT
8050         s1=dipderg(3,jj,i)*dip(1,kk,k)
8051 #endif
8052         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8053         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8054         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8055         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8056         vv(1)=pizda(1,1)-pizda(2,2)
8057         vv(2)=pizda(1,2)+pizda(2,1)
8058         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8059 #ifdef MOMENT
8060         if (swap) then
8061           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8062         else
8063           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8064         endif
8065 #endif
8066         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8067 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8068       endif
8069 C Derivatives in gamma(l-1) or gamma(j-1)
8070       if (l.gt.1) then
8071 #ifdef MOMENT
8072         s1=dip(1,jj,i)*dipderg(3,kk,k)
8073 #endif
8074         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8075         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8076         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8077         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8078         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8079         vv(1)=pizda(1,1)-pizda(2,2)
8080         vv(2)=pizda(1,2)+pizda(2,1)
8081         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8082 #ifdef MOMENT
8083         if (swap) then
8084           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8085         else
8086           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8087         endif
8088 #endif
8089         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8090 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8091       endif
8092 C Cartesian derivatives.
8093       if (lprn) then
8094         write (2,*) 'In eello6_graph2'
8095         do iii=1,2
8096           write (2,*) 'iii=',iii
8097           do kkk=1,5
8098             write (2,*) 'kkk=',kkk
8099             do jjj=1,2
8100               write (2,'(3(2f10.5),5x)')
8101      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8102             enddo
8103           enddo
8104         enddo
8105       endif
8106       do iii=1,2
8107         do kkk=1,5
8108           do lll=1,3
8109 #ifdef MOMENT
8110             if (iii.eq.1) then
8111               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8112             else
8113               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8114             endif
8115 #endif
8116             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8117      &        auxvec(1))
8118             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8119             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8120      &        auxvec(1))
8121             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8122             call transpose2(EUg(1,1,k),auxmat(1,1))
8123             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8124      &        pizda(1,1))
8125             vv(1)=pizda(1,1)-pizda(2,2)
8126             vv(2)=pizda(1,2)+pizda(2,1)
8127             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8128 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8129 #ifdef MOMENT
8130             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8131 #else
8132             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8133 #endif
8134             if (swap) then
8135               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8136             else
8137               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8138             endif
8139           enddo
8140         enddo
8141       enddo
8142       return
8143       end
8144 c----------------------------------------------------------------------------
8145       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8146       implicit real*8 (a-h,o-z)
8147       include 'DIMENSIONS'
8148       include 'COMMON.IOUNITS'
8149       include 'COMMON.CHAIN'
8150       include 'COMMON.DERIV'
8151       include 'COMMON.INTERACT'
8152       include 'COMMON.CONTACTS'
8153       include 'COMMON.TORSION'
8154       include 'COMMON.VAR'
8155       include 'COMMON.GEO'
8156       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8157       logical swap
8158 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8159 C                                                                              C
8160 C      Parallel       Antiparallel                                             C
8161 C                                                                              C
8162 C          o             o                                                     C
8163 C         /l\   /   \   /j\                                                    C
8164 C        /   \ /     \ /   \                                                   C
8165 C       /| o |o       o| o |\                                                  C
8166 C       j|/k\|  /      |/k\|l /                                                C
8167 C        /   \ /       /   \ /                                                 C
8168 C       /     o       /     o                                                  C
8169 C       i             i                                                        C
8170 C                                                                              C
8171 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8172 C
8173 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8174 C           energy moment and not to the cluster cumulant.
8175       iti=itortyp(itype(i))
8176       if (j.lt.nres-1) then
8177         itj1=itortyp(itype(j+1))
8178       else
8179         itj1=ntortyp+1
8180       endif
8181       itk=itortyp(itype(k))
8182       itk1=itortyp(itype(k+1))
8183       if (l.lt.nres-1) then
8184         itl1=itortyp(itype(l+1))
8185       else
8186         itl1=ntortyp+1
8187       endif
8188 #ifdef MOMENT
8189       s1=dip(4,jj,i)*dip(4,kk,k)
8190 #endif
8191       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8192       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8193       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8194       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8195       call transpose2(EE(1,1,itk),auxmat(1,1))
8196       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8197       vv(1)=pizda(1,1)+pizda(2,2)
8198       vv(2)=pizda(2,1)-pizda(1,2)
8199       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8200 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8201 cd     & "sum",-(s2+s3+s4)
8202 #ifdef MOMENT
8203       eello6_graph3=-(s1+s2+s3+s4)
8204 #else
8205       eello6_graph3=-(s2+s3+s4)
8206 #endif
8207 c      eello6_graph3=-s4
8208 C Derivatives in gamma(k-1)
8209       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8210       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8211       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8212       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8213 C Derivatives in gamma(l-1)
8214       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8215       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8216       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8217       vv(1)=pizda(1,1)+pizda(2,2)
8218       vv(2)=pizda(2,1)-pizda(1,2)
8219       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8220       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8221 C Cartesian derivatives.
8222       do iii=1,2
8223         do kkk=1,5
8224           do lll=1,3
8225 #ifdef MOMENT
8226             if (iii.eq.1) then
8227               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8228             else
8229               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8230             endif
8231 #endif
8232             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8233      &        auxvec(1))
8234             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8235             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8236      &        auxvec(1))
8237             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8238             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8239      &        pizda(1,1))
8240             vv(1)=pizda(1,1)+pizda(2,2)
8241             vv(2)=pizda(2,1)-pizda(1,2)
8242             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8243 #ifdef MOMENT
8244             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8245 #else
8246             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8247 #endif
8248             if (swap) then
8249               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8250             else
8251               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8252             endif
8253 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8254           enddo
8255         enddo
8256       enddo
8257       return
8258       end
8259 c----------------------------------------------------------------------------
8260       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8261       implicit real*8 (a-h,o-z)
8262       include 'DIMENSIONS'
8263       include 'COMMON.IOUNITS'
8264       include 'COMMON.CHAIN'
8265       include 'COMMON.DERIV'
8266       include 'COMMON.INTERACT'
8267       include 'COMMON.CONTACTS'
8268       include 'COMMON.TORSION'
8269       include 'COMMON.VAR'
8270       include 'COMMON.GEO'
8271       include 'COMMON.FFIELD'
8272       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8273      & auxvec1(2),auxmat1(2,2)
8274       logical swap
8275 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8276 C                                                                              C
8277 C      Parallel       Antiparallel                                             C
8278 C                                                                              C
8279 C          o             o                                                     C
8280 C         /l\   /   \   /j\                                                    C
8281 C        /   \ /     \ /   \                                                   C
8282 C       /| o |o       o| o |\                                                  C
8283 C     \ j|/k\|      \  |/k\|l                                                  C
8284 C      \ /   \       \ /   \                                                   C
8285 C       o     \       o     \                                                  C
8286 C       i             i                                                        C
8287 C                                                                              C
8288 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8289 C
8290 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8291 C           energy moment and not to the cluster cumulant.
8292 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8293       iti=itortyp(itype(i))
8294       itj=itortyp(itype(j))
8295       if (j.lt.nres-1) then
8296         itj1=itortyp(itype(j+1))
8297       else
8298         itj1=ntortyp+1
8299       endif
8300       itk=itortyp(itype(k))
8301       if (k.lt.nres-1) then
8302         itk1=itortyp(itype(k+1))
8303       else
8304         itk1=ntortyp+1
8305       endif
8306       itl=itortyp(itype(l))
8307       if (l.lt.nres-1) then
8308         itl1=itortyp(itype(l+1))
8309       else
8310         itl1=ntortyp+1
8311       endif
8312 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8313 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8314 cd     & ' itl',itl,' itl1',itl1
8315 #ifdef MOMENT
8316       if (imat.eq.1) then
8317         s1=dip(3,jj,i)*dip(3,kk,k)
8318       else
8319         s1=dip(2,jj,j)*dip(2,kk,l)
8320       endif
8321 #endif
8322       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8323       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8324       if (j.eq.l+1) then
8325         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8326         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8327       else
8328         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8329         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8330       endif
8331       call transpose2(EUg(1,1,k),auxmat(1,1))
8332       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8333       vv(1)=pizda(1,1)-pizda(2,2)
8334       vv(2)=pizda(2,1)+pizda(1,2)
8335       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8336 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8337 #ifdef MOMENT
8338       eello6_graph4=-(s1+s2+s3+s4)
8339 #else
8340       eello6_graph4=-(s2+s3+s4)
8341 #endif
8342 C Derivatives in gamma(i-1)
8343       if (i.gt.1) then
8344 #ifdef MOMENT
8345         if (imat.eq.1) then
8346           s1=dipderg(2,jj,i)*dip(3,kk,k)
8347         else
8348           s1=dipderg(4,jj,j)*dip(2,kk,l)
8349         endif
8350 #endif
8351         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8352         if (j.eq.l+1) then
8353           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8354           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8355         else
8356           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8357           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8358         endif
8359         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8360         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8361 cd          write (2,*) 'turn6 derivatives'
8362 #ifdef MOMENT
8363           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8364 #else
8365           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8366 #endif
8367         else
8368 #ifdef MOMENT
8369           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8370 #else
8371           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8372 #endif
8373         endif
8374       endif
8375 C Derivatives in gamma(k-1)
8376 #ifdef MOMENT
8377       if (imat.eq.1) then
8378         s1=dip(3,jj,i)*dipderg(2,kk,k)
8379       else
8380         s1=dip(2,jj,j)*dipderg(4,kk,l)
8381       endif
8382 #endif
8383       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8384       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8385       if (j.eq.l+1) then
8386         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8387         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8388       else
8389         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8390         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8391       endif
8392       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8393       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8394       vv(1)=pizda(1,1)-pizda(2,2)
8395       vv(2)=pizda(2,1)+pizda(1,2)
8396       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8397       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8398 #ifdef MOMENT
8399         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8400 #else
8401         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8402 #endif
8403       else
8404 #ifdef MOMENT
8405         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8406 #else
8407         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8408 #endif
8409       endif
8410 C Derivatives in gamma(j-1) or gamma(l-1)
8411       if (l.eq.j+1 .and. l.gt.1) then
8412         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8413         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8414         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8415         vv(1)=pizda(1,1)-pizda(2,2)
8416         vv(2)=pizda(2,1)+pizda(1,2)
8417         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8418         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8419       else if (j.gt.1) then
8420         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8421         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8422         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8423         vv(1)=pizda(1,1)-pizda(2,2)
8424         vv(2)=pizda(2,1)+pizda(1,2)
8425         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8426         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8427           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8428         else
8429           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8430         endif
8431       endif
8432 C Cartesian derivatives.
8433       do iii=1,2
8434         do kkk=1,5
8435           do lll=1,3
8436 #ifdef MOMENT
8437             if (iii.eq.1) then
8438               if (imat.eq.1) then
8439                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8440               else
8441                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8442               endif
8443             else
8444               if (imat.eq.1) then
8445                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8446               else
8447                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8448               endif
8449             endif
8450 #endif
8451             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8452      &        auxvec(1))
8453             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8454             if (j.eq.l+1) then
8455               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8456      &          b1(1,itj1),auxvec(1))
8457               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8458             else
8459               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8460      &          b1(1,itl1),auxvec(1))
8461               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8462             endif
8463             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8464      &        pizda(1,1))
8465             vv(1)=pizda(1,1)-pizda(2,2)
8466             vv(2)=pizda(2,1)+pizda(1,2)
8467             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8468             if (swap) then
8469               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8470 #ifdef MOMENT
8471                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8472      &             -(s1+s2+s4)
8473 #else
8474                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8475      &             -(s2+s4)
8476 #endif
8477                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8478               else
8479 #ifdef MOMENT
8480                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8481 #else
8482                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8483 #endif
8484                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8485               endif
8486             else
8487 #ifdef MOMENT
8488               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8489 #else
8490               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8491 #endif
8492               if (l.eq.j+1) then
8493                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8494               else
8495                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8496               endif
8497             endif
8498           enddo
8499         enddo
8500       enddo
8501       return
8502       end
8503 c----------------------------------------------------------------------------
8504       double precision function eello_turn6(i,jj,kk)
8505       implicit real*8 (a-h,o-z)
8506       include 'DIMENSIONS'
8507       include 'COMMON.IOUNITS'
8508       include 'COMMON.CHAIN'
8509       include 'COMMON.DERIV'
8510       include 'COMMON.INTERACT'
8511       include 'COMMON.CONTACTS'
8512       include 'COMMON.TORSION'
8513       include 'COMMON.VAR'
8514       include 'COMMON.GEO'
8515       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8516      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8517      &  ggg1(3),ggg2(3)
8518       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8519      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8520 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8521 C           the respective energy moment and not to the cluster cumulant.
8522       s1=0.0d0
8523       s8=0.0d0
8524       s13=0.0d0
8525 c
8526       eello_turn6=0.0d0
8527       j=i+4
8528       k=i+1
8529       l=i+3
8530       iti=itortyp(itype(i))
8531       itk=itortyp(itype(k))
8532       itk1=itortyp(itype(k+1))
8533       itl=itortyp(itype(l))
8534       itj=itortyp(itype(j))
8535 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8536 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8537 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8538 cd        eello6=0.0d0
8539 cd        return
8540 cd      endif
8541 cd      write (iout,*)
8542 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8543 cd     &   ' and',k,l
8544 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8545       do iii=1,2
8546         do kkk=1,5
8547           do lll=1,3
8548             derx_turn(lll,kkk,iii)=0.0d0
8549           enddo
8550         enddo
8551       enddo
8552 cd      eij=1.0d0
8553 cd      ekl=1.0d0
8554 cd      ekont=1.0d0
8555       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8556 cd      eello6_5=0.0d0
8557 cd      write (2,*) 'eello6_5',eello6_5
8558 #ifdef MOMENT
8559       call transpose2(AEA(1,1,1),auxmat(1,1))
8560       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8561       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8562       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8563 #endif
8564       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8565       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8566       s2 = scalar2(b1(1,itk),vtemp1(1))
8567 #ifdef MOMENT
8568       call transpose2(AEA(1,1,2),atemp(1,1))
8569       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8570       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8571       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8572 #endif
8573       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8574       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8575       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8576 #ifdef MOMENT
8577       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8578       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8579       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8580       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8581       ss13 = scalar2(b1(1,itk),vtemp4(1))
8582       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8583 #endif
8584 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8585 c      s1=0.0d0
8586 c      s2=0.0d0
8587 c      s8=0.0d0
8588 c      s12=0.0d0
8589 c      s13=0.0d0
8590       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8591 C Derivatives in gamma(i+2)
8592       s1d =0.0d0
8593       s8d =0.0d0
8594 #ifdef MOMENT
8595       call transpose2(AEA(1,1,1),auxmatd(1,1))
8596       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8597       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8598       call transpose2(AEAderg(1,1,2),atempd(1,1))
8599       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8600       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8601 #endif
8602       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8603       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8604       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8605 c      s1d=0.0d0
8606 c      s2d=0.0d0
8607 c      s8d=0.0d0
8608 c      s12d=0.0d0
8609 c      s13d=0.0d0
8610       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8611 C Derivatives in gamma(i+3)
8612 #ifdef MOMENT
8613       call transpose2(AEA(1,1,1),auxmatd(1,1))
8614       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8615       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8616       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8617 #endif
8618       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8619       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8620       s2d = scalar2(b1(1,itk),vtemp1d(1))
8621 #ifdef MOMENT
8622       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8623       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8624 #endif
8625       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8626 #ifdef MOMENT
8627       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8628       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8629       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8630 #endif
8631 c      s1d=0.0d0
8632 c      s2d=0.0d0
8633 c      s8d=0.0d0
8634 c      s12d=0.0d0
8635 c      s13d=0.0d0
8636 #ifdef MOMENT
8637       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8638      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8639 #else
8640       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8641      &               -0.5d0*ekont*(s2d+s12d)
8642 #endif
8643 C Derivatives in gamma(i+4)
8644       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8645       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8646       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8647 #ifdef MOMENT
8648       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8649       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8650       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8651 #endif
8652 c      s1d=0.0d0
8653 c      s2d=0.0d0
8654 c      s8d=0.0d0
8655 C      s12d=0.0d0
8656 c      s13d=0.0d0
8657 #ifdef MOMENT
8658       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8659 #else
8660       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8661 #endif
8662 C Derivatives in gamma(i+5)
8663 #ifdef MOMENT
8664       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8665       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8666       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8667 #endif
8668       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8669       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8670       s2d = scalar2(b1(1,itk),vtemp1d(1))
8671 #ifdef MOMENT
8672       call transpose2(AEA(1,1,2),atempd(1,1))
8673       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8674       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8675 #endif
8676       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8677       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8678 #ifdef MOMENT
8679       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8680       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8681       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8682 #endif
8683 c      s1d=0.0d0
8684 c      s2d=0.0d0
8685 c      s8d=0.0d0
8686 c      s12d=0.0d0
8687 c      s13d=0.0d0
8688 #ifdef MOMENT
8689       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8690      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8691 #else
8692       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8693      &               -0.5d0*ekont*(s2d+s12d)
8694 #endif
8695 C Cartesian derivatives
8696       do iii=1,2
8697         do kkk=1,5
8698           do lll=1,3
8699 #ifdef MOMENT
8700             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8701             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8702             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8703 #endif
8704             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8705             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8706      &          vtemp1d(1))
8707             s2d = scalar2(b1(1,itk),vtemp1d(1))
8708 #ifdef MOMENT
8709             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8710             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8711             s8d = -(atempd(1,1)+atempd(2,2))*
8712      &           scalar2(cc(1,1,itl),vtemp2(1))
8713 #endif
8714             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8715      &           auxmatd(1,1))
8716             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8717             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8718 c      s1d=0.0d0
8719 c      s2d=0.0d0
8720 c      s8d=0.0d0
8721 c      s12d=0.0d0
8722 c      s13d=0.0d0
8723 #ifdef MOMENT
8724             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8725      &        - 0.5d0*(s1d+s2d)
8726 #else
8727             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8728      &        - 0.5d0*s2d
8729 #endif
8730 #ifdef MOMENT
8731             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8732      &        - 0.5d0*(s8d+s12d)
8733 #else
8734             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8735      &        - 0.5d0*s12d
8736 #endif
8737           enddo
8738         enddo
8739       enddo
8740 #ifdef MOMENT
8741       do kkk=1,5
8742         do lll=1,3
8743           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8744      &      achuj_tempd(1,1))
8745           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8746           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8747           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8748           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8749           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8750      &      vtemp4d(1))
8751           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8752           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8753           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8754         enddo
8755       enddo
8756 #endif
8757 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8758 cd     &  16*eel_turn6_num
8759 cd      goto 1112
8760       if (j.lt.nres-1) then
8761         j1=j+1
8762         j2=j-1
8763       else
8764         j1=j-1
8765         j2=j-2
8766       endif
8767       if (l.lt.nres-1) then
8768         l1=l+1
8769         l2=l-1
8770       else
8771         l1=l-1
8772         l2=l-2
8773       endif
8774       do ll=1,3
8775 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8776 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8777 cgrad        ghalf=0.5d0*ggg1(ll)
8778 cd        ghalf=0.0d0
8779         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8780         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8781         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8782      &    +ekont*derx_turn(ll,2,1)
8783         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8784         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8785      &    +ekont*derx_turn(ll,4,1)
8786         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8787         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8788         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8789 cgrad        ghalf=0.5d0*ggg2(ll)
8790 cd        ghalf=0.0d0
8791         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8792      &    +ekont*derx_turn(ll,2,2)
8793         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8794         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8795      &    +ekont*derx_turn(ll,4,2)
8796         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8797         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8798         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8799       enddo
8800 cd      goto 1112
8801 cgrad      do m=i+1,j-1
8802 cgrad        do ll=1,3
8803 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8804 cgrad        enddo
8805 cgrad      enddo
8806 cgrad      do m=k+1,l-1
8807 cgrad        do ll=1,3
8808 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8809 cgrad        enddo
8810 cgrad      enddo
8811 cgrad1112  continue
8812 cgrad      do m=i+2,j2
8813 cgrad        do ll=1,3
8814 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8815 cgrad        enddo
8816 cgrad      enddo
8817 cgrad      do m=k+2,l2
8818 cgrad        do ll=1,3
8819 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8820 cgrad        enddo
8821 cgrad      enddo
8822 cd      do iii=1,nres-3
8823 cd        write (2,*) iii,g_corr6_loc(iii)
8824 cd      enddo
8825       eello_turn6=ekont*eel_turn6
8826 cd      write (2,*) 'ekont',ekont
8827 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8828       return
8829       end
8830
8831 C-----------------------------------------------------------------------------
8832       double precision function scalar(u,v)
8833 !DIR$ INLINEALWAYS scalar
8834 #ifndef OSF
8835 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8836 #endif
8837       implicit none
8838       double precision u(3),v(3)
8839 cd      double precision sc
8840 cd      integer i
8841 cd      sc=0.0d0
8842 cd      do i=1,3
8843 cd        sc=sc+u(i)*v(i)
8844 cd      enddo
8845 cd      scalar=sc
8846
8847       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8848       return
8849       end
8850 crc-------------------------------------------------
8851       SUBROUTINE MATVEC2(A1,V1,V2)
8852 !DIR$ INLINEALWAYS MATVEC2
8853 #ifndef OSF
8854 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8855 #endif
8856       implicit real*8 (a-h,o-z)
8857       include 'DIMENSIONS'
8858       DIMENSION A1(2,2),V1(2),V2(2)
8859 c      DO 1 I=1,2
8860 c        VI=0.0
8861 c        DO 3 K=1,2
8862 c    3     VI=VI+A1(I,K)*V1(K)
8863 c        Vaux(I)=VI
8864 c    1 CONTINUE
8865
8866       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8867       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8868
8869       v2(1)=vaux1
8870       v2(2)=vaux2
8871       END
8872 C---------------------------------------
8873       SUBROUTINE MATMAT2(A1,A2,A3)
8874 #ifndef OSF
8875 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8876 #endif
8877       implicit real*8 (a-h,o-z)
8878       include 'DIMENSIONS'
8879       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8880 c      DIMENSION AI3(2,2)
8881 c        DO  J=1,2
8882 c          A3IJ=0.0
8883 c          DO K=1,2
8884 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8885 c          enddo
8886 c          A3(I,J)=A3IJ
8887 c       enddo
8888 c      enddo
8889
8890       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8891       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8892       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8893       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8894
8895       A3(1,1)=AI3_11
8896       A3(2,1)=AI3_21
8897       A3(1,2)=AI3_12
8898       A3(2,2)=AI3_22
8899       END
8900
8901 c-------------------------------------------------------------------------
8902       double precision function scalar2(u,v)
8903 !DIR$ INLINEALWAYS scalar2
8904       implicit none
8905       double precision u(2),v(2)
8906       double precision sc
8907       integer i
8908       scalar2=u(1)*v(1)+u(2)*v(2)
8909       return
8910       end
8911
8912 C-----------------------------------------------------------------------------
8913
8914       subroutine transpose2(a,at)
8915 !DIR$ INLINEALWAYS transpose2
8916 #ifndef OSF
8917 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8918 #endif
8919       implicit none
8920       double precision a(2,2),at(2,2)
8921       at(1,1)=a(1,1)
8922       at(1,2)=a(2,1)
8923       at(2,1)=a(1,2)
8924       at(2,2)=a(2,2)
8925       return
8926       end
8927 c--------------------------------------------------------------------------
8928       subroutine transpose(n,a,at)
8929       implicit none
8930       integer n,i,j
8931       double precision a(n,n),at(n,n)
8932       do i=1,n
8933         do j=1,n
8934           at(j,i)=a(i,j)
8935         enddo
8936       enddo
8937       return
8938       end
8939 C---------------------------------------------------------------------------
8940       subroutine prodmat3(a1,a2,kk,transp,prod)
8941 !DIR$ INLINEALWAYS prodmat3
8942 #ifndef OSF
8943 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8944 #endif
8945       implicit none
8946       integer i,j
8947       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8948       logical transp
8949 crc      double precision auxmat(2,2),prod_(2,2)
8950
8951       if (transp) then
8952 crc        call transpose2(kk(1,1),auxmat(1,1))
8953 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8954 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8955
8956            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8957      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8958            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8959      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8960            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8961      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8962            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8963      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8964
8965       else
8966 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8967 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8968
8969            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8970      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8971            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8972      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8973            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8974      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8975            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8976      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8977
8978       endif
8979 c      call transpose2(a2(1,1),a2t(1,1))
8980
8981 crc      print *,transp
8982 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8983 crc      print *,((prod(i,j),i=1,2),j=1,2)
8984
8985       return
8986       end
8987