source/unres/src_MD/src/old_F/energy_p_new.F.elec-pair

   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       if (modecalc.eq.12.or.modecalc.eq.14) then
  28 #ifdef MPI
  29 c        if (fg_rank.eq.0) call int_from_cart1(.false.)
  30 #else
  31         call int_from_cart1(.false.)
  32 #endif
  33       endif
  34 #ifdef MPI
  35 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  36 c     & " nfgtasks",nfgtasks
  37       if (nfgtasks.gt.1) then
  38         time00=MPI_Wtime()
  39 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  40         if (fg_rank.eq.0) then
  41           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  42 c          print *,"Processor",myrank," BROADCAST iorder"
  43 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  44 C FG slaves as WEIGHTS array.
  45           weights_(1)=wsc
  46           weights_(2)=wscp
  47           weights_(3)=welec
  48           weights_(4)=wcorr
  49           weights_(5)=wcorr5
  50           weights_(6)=wcorr6
  51           weights_(7)=wel_loc
  52           weights_(8)=wturn3
  53           weights_(9)=wturn4
  54           weights_(10)=wturn6
  55           weights_(11)=wang
  56           weights_(12)=wscloc
  57           weights_(13)=wtor
  58           weights_(14)=wtor_d
  59           weights_(15)=wstrain
  60           weights_(16)=wvdwpp
  61           weights_(17)=wbond
  62           weights_(18)=scal14
  63           weights_(21)=wsccor
  64 C FG Master broadcasts the WEIGHTS_ array
  65           call MPI_Bcast(weights_(1),n_ene,
  66      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  67         else
  68 C FG slaves receive the WEIGHTS array
  69           call MPI_Bcast(weights(1),n_ene,
  70      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  71         endif
  72 c        print *,"Processor",myrank," BROADCAST weights"
  73 c        call MPI_Bcast(c(1,1),maxres6,MPI_DOUBLE_PRECISION,
  74 c     &    king,FG_COMM,IERR)
  75 c        call MPI_Bcast(c(1,1),6*nres,MPI_DOUBLE_PRECISION,
  76 c     &    king,FG_COMM,IERR)
  77 c        print *,"Processor",myrank," BROADCAST c"
  78 c        call MPI_Bcast(dc(1,1),maxres6,MPI_DOUBLE_PRECISION,
  79 c     &    king,FG_COMM,IERR)
  80         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,
  81      &    king,FG_COMM,IERR)
  82 c        print *,"Processor",myrank," BROADCAST dc"
  83 c        call MPI_Bcast(dc_norm(1,1),maxres6,MPI_DOUBLE_PRECISION,
  84 c     &    king,FG_COMM,IERR)
  85 c        call MPI_Bcast(dc_norm(1,1),6*nres,MPI_DOUBLE_PRECISION,
  86 c     &    king,FG_COMM,IERR)
  87 c        print *,"Processor",myrank," BROADCAST dc_norm"
  88 c        call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,
  89 c     &    king,FG_COMM,IERR)
  90 c        print *,"Processor",myrank," BROADCAST theta"
  91 c        call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,
  92 c     &    king,FG_COMM,IERR)
  93 c        print *,"Processor",myrank," BROADCAST phi"
  94 c        call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,
  95 c     &    king,FG_COMM,IERR)
  96 c        print *,"Processor",myrank," BROADCAST alph"
  97 c        call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,
  98 c     &    king,FG_COMM,IERR)
  99 c        print *,"Processor",myrank," BROADCAST omeg"
 100 c        call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,
 101 c     &    king,FG_COMM,IERR)
 102 c        print *,"Processor",myrank," BROADCAST vbld"
 103 c        call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,
 104 c     &    king,FG_COMM,IERR)
 105         time_Bcast=time_Bcast+MPI_Wtime()-time00
 106         call chainbuild_cart
 107         call int_from_cart1(.false.)
 108 c        print *,"Processor",myrank," BROADCAST vbld_inv"
 109       endif
 110 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
 111 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 112 #endif
 113 C
 114 C Compute the side-chain and electrostatic interaction energy
 115 C
 116       goto (101,102,103,104,105,106) ipot
 117 C Lennard-Jones potential.
 118   101 call elj(evdw)
 119 cd    print '(a)','Exit ELJ'
 120       goto 107
 121 C Lennard-Jones-Kihara potential (shifted).
 122   102 call eljk(evdw)
 123       goto 107
 124 C Berne-Pechukas potential (dilated LJ, angular dependence).
 125   103 call ebp(evdw)
 126       goto 107
 127 C Gay-Berne potential (shifted LJ, angular dependence).
 128   104 call egb(evdw)
 129       goto 107
 130 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 131   105 call egbv(evdw)
 132       goto 107
 133 C Soft-sphere potential
 134   106 call e_softsphere(evdw)
 135 C
 136 C Calculate electrostatic (H-bonding) energy of the main chain.
 137 C
 138   107 continue
 139 c      print *,"Processor",myrank," computed USCSC"
 140       call vec_and_deriv
 141 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 142       if (ipot.lt.6) then
 143 #ifdef SPLITELE
 144          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 145      &       wturn3.gt.0d0.or.wturn4.gt.0d0) then
 146 #else
 147          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 148      &       wturn3.gt.0d0.or.wturn4.gt.0d0) then
 149 #endif
 150             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 151          else
 152             ees=0
 153             evdw1=0
 154             eel_loc=0
 155             eello_turn3=0
 156             eello_turn4=0
 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 c         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
 241 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 242       else
 243          ecorr=0
 244          ecorr5=0
 245          ecorr6=0
 246          eturn6=0
 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       else
 251          ecorr=0
 252          ecorr5=0
 253          ecorr6=0
 254          eturn6=0
 255       endif
 256 c      print *,"Processor",myrank," computed Ucorr"
 257 C
 258 C If performing constraint dynamics, call the constraint energy
 259 C  after the equilibration time
 260       if(usampl.and.totT.gt.eq_time) then
 261          call EconstrQ
 262          call Econstr_back
 263       else
 264          Uconst=0.0d0
 265          Uconst_back=0.0d0
 266       endif
 267 c      print *,"Processor",myrank," computed Uconstr"
 268 c
 269 C Sum the energies
 270 C
 271       energia(1)=evdw
 272 #ifdef SCP14
 273       energia(2)=evdw2-evdw2_14
 274       energia(18)=evdw2_14
 275 #else
 276       energia(2)=evdw2
 277       energia(18)=0.0d0
 278 #endif
 279 #ifdef SPLITELE
 280       energia(3)=ees
 281       energia(16)=evdw1
 282 #else
 283       energia(3)=ees+evdw1
 284       energia(16)=0.0d0
 285 #endif
 286       energia(4)=ecorr
 287       energia(5)=ecorr5
 288       energia(6)=ecorr6
 289       energia(7)=eel_loc
 290       energia(8)=eello_turn3
 291       energia(9)=eello_turn4
 292       energia(10)=eturn6
 293       energia(11)=ebe
 294       energia(12)=escloc
 295       energia(13)=etors
 296       energia(14)=etors_d
 297       energia(15)=ehpb
 298       energia(19)=edihcnstr
 299       energia(17)=estr
 300       energia(20)=Uconst+Uconst_back
 301       energia(21)=esccor
 302 c      print *," Processor",myrank," calls SUM_ENERGY"
 303       call sum_energy(energia,.true.)
 304 c      print *," Processor",myrank," left SUM_ENERGY"
 305       return
 306       end
 307 c-------------------------------------------------------------------------------
 308       subroutine sum_energy(energia,reduce)
 309       implicit real*8 (a-h,o-z)
 310       include 'DIMENSIONS'
 311 #ifndef ISNAN
 312       external proc_proc
 313 #ifdef WINPGI
 314 cMS$ATTRIBUTES C ::  proc_proc
 315 #endif
 316 #endif
 317 #ifdef MPI
 318       include "mpif.h"
 319 #endif
 320       include 'COMMON.SETUP'
 321       include 'COMMON.IOUNITS'
 322       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 323       include 'COMMON.FFIELD'
 324       include 'COMMON.DERIV'
 325       include 'COMMON.INTERACT'
 326       include 'COMMON.SBRIDGE'
 327       include 'COMMON.CHAIN'
 328       include 'COMMON.VAR'
 329       include 'COMMON.CONTROL'
 330       include 'COMMON.TIME1'
 331       logical reduce
 332 #ifdef MPI
 333       if (nfgtasks.gt.1 .and. reduce) then
 334 #ifdef DEBUG
 335         write (iout,*) "energies before REDUCE"
 336         call enerprint(energia)
 337         call flush(iout)
 338 #endif
 339         do i=0,n_ene
 340           enebuff(i)=energia(i)
 341         enddo
 342         time00=MPI_Wtime()
 343         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 344      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 345 #ifdef DEBUG
 346         write (iout,*) "energies after REDUCE"
 347         call enerprint(energia)
 348         call flush(iout)
 349 #endif
 350         time_Reduce=time_Reduce+MPI_Wtime()-time00
 351       endif
 352       if (fg_rank.eq.0) then
 353 #endif
 354       evdw=energia(1)
 355 #ifdef SCP14
 356       evdw2=energia(2)+energia(18)
 357       evdw2_14=energia(18)
 358 #else
 359       evdw2=energia(2)
 360 #endif
 361 #ifdef SPLITELE
 362       ees=energia(3)
 363       evdw1=energia(16)
 364 #else
 365       ees=energia(3)
 366       evdw1=0.0d0
 367 #endif
 368       ecorr=energia(4)
 369       ecorr5=energia(5)
 370       ecorr6=energia(6)
 371       eel_loc=energia(7)
 372       eello_turn3=energia(8)
 373       eello_turn4=energia(9)
 374       eturn6=energia(10)
 375       ebe=energia(11)
 376       escloc=energia(12)
 377       etors=energia(13)
 378       etors_d=energia(14)
 379       ehpb=energia(15)
 380       edihcnstr=energia(19)
 381       estr=energia(17)
 382       Uconst=energia(20)
 383       esccor=energia(21)
 384 #ifdef SPLITELE
 385       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 386      & +wang*ebe+wtor*etors+wscloc*escloc
 387      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 388      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 389      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 390      & +wbond*estr+Uconst+wsccor*esccor
 391 #else
 392       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 393      & +wang*ebe+wtor*etors+wscloc*escloc
 394      & +wstrain*ehpb+nss*ebr+wcorr*ecorr+wcorr5*ecorr5
 395      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 396      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 397      & +wbond*estr+Uconst+wsccor*esccor
 398 #endif
 399       energia(0)=etot
 400 c detecting NaNQ
 401 #ifdef ISNAN
 402 #ifdef AIX
 403       if (isnan(etot).ne.0) energia(0)=1.0d+99
 404 #else
 405       if (isnan(etot)) energia(0)=1.0d+99
 406 #endif
 407 #else
 408       i=0
 409 #ifdef WINPGI
 410       idumm=proc_proc(etot,i)
 411 #else
 412       call proc_proc(etot,i)
 413 #endif
 414       if(i.eq.1)energia(0)=1.0d+99
 415 #endif
 416 #ifdef MPI
 417       endif
 418 #endif
 419       return
 420       end
 421 c-------------------------------------------------------------------------------
 422       subroutine sum_gradient
 423       implicit real*8 (a-h,o-z)
 424       include 'DIMENSIONS'
 425 #ifndef ISNAN
 426       external proc_proc
 427 #ifdef WINPGI
 428 cMS$ATTRIBUTES C ::  proc_proc
 429 #endif
 430 #endif
 431 #ifdef MPI
 432       include 'mpif.h'
 433       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 434      &  glocbuf(4*maxres)
 435 #endif
 436       include 'COMMON.SETUP'
 437       include 'COMMON.IOUNITS'
 438       include 'COMMON.FFIELD'
 439       include 'COMMON.DERIV'
 440       include 'COMMON.INTERACT'
 441       include 'COMMON.SBRIDGE'
 442       include 'COMMON.CHAIN'
 443       include 'COMMON.VAR'
 444       include 'COMMON.CONTROL'
 445       include 'COMMON.TIME1'
 446       include 'COMMON.MAXGRAD'
 447 C
 448 C Sum up the components of the Cartesian gradient.
 449 C
 450 #ifdef SPLITELE
 451       do i=1,nct
 452         do j=1,3
 453           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 454      &                welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 455      &                wbond*gradb(j,i)+
 456      &                wstrain*ghpbc(j,i)+
 457      &                wcorr*gradcorr(j,i)+
 458      &                wel_loc*gel_loc(j,i)+
 459      &                wturn3*gcorr3_turn(j,i)+
 460      &                wturn4*gcorr4_turn(j,i)+
 461      &                wcorr5*gradcorr5(j,i)+
 462      &                wcorr6*gradcorr6(j,i)+
 463      &                wturn6*gcorr6_turn(j,i)+
 464      &                wsccor*gsccorc(j,i)
 465      &               +wscloc*gscloc(j,i)
 466           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 467      &                  wbond*gradbx(j,i)+
 468      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 469      &                  wsccor*gsccorx(j,i)
 470      &                 +wscloc*gsclocx(j,i)
 471         enddo
 472       enddo
 473 #else
 474       do i=1,nct
 475         do j=1,3
 476           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 477      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 478      &                wbond*gradb(j,i)+
 479      &                wcorr*gradcorr(j,i)+
 480      &                wel_loc*gel_loc(j,i)+
 481      &                wturn3*gcorr3_turn(j,i)+
 482      &                wturn4*gcorr4_turn(j,i)+
 483      &                wcorr5*gradcorr5(j,i)+
 484      &                wcorr6*gradcorr6(j,i)+
 485      &                wturn6*gcorr6_turn(j,i)+
 486      &                wsccor*gsccorc(j,i)
 487      &               +wscloc*gscloc(j,i)
 488           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 489      &                  wbond*gradbx(j,i)+
 490      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 491      &                  wsccor*gsccorx(j,i)
 492      &                 +wscloc*gsclocx(j,i)
 493         enddo
 494       enddo
 495 #endif
 496       do i=1,nres-3
 497         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 498      &   +wcorr5*g_corr5_loc(i)
 499      &   +wcorr6*g_corr6_loc(i)
 500      &   +wturn4*gel_loc_turn4(i)
 501      &   +wturn3*gel_loc_turn3(i)
 502      &   +wturn6*gel_loc_turn6(i)
 503      &   +wel_loc*gel_loc_loc(i)
 504      &   +wsccor*gsccor_loc(i)
 505       enddo
 506 #ifdef MPI
 507       if (nfgtasks.gt.1) then
 508         do j=1,3
 509           do i=1,nres
 510             gradbufc(j,i)=gradc(j,i,icg)
 511             gradbufx(j,i)=gradx(j,i,icg)
 512           enddo
 513         enddo
 514         do i=1,4*nres
 515           glocbuf(i)=gloc(i,icg)
 516         enddo
 517 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 518         if (fg_rank.eq.0) call MPI_Bcast(1,1,MPI_INTEGER,
 519      &      king,FG_COMM,IERROR)
 520         time00=MPI_Wtime()
 521         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 522      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 523         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 524      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 525         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 526      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 527         time_reduce=time_reduce+MPI_Wtime()-time00
 528       endif
 529 #endif
 530       if (gnorm_check) then
 531 c
 532 c Compute the maximum elements of the gradient
 533 c
 534       gvdwc_max=0.0d0
 535       gvdwc_scp_max=0.0d0
 536       gelc_max=0.0d0
 537       gvdwpp_max=0.0d0
 538       gradb_max=0.0d0
 539       ghpbc_max=0.0d0
 540       gradcorr_max=0.0d0
 541       gel_loc_max=0.0d0
 542       gcorr3_turn_max=0.0d0
 543       gcorr4_turn_max=0.0d0
 544       gradcorr5_max=0.0d0
 545       gradcorr6_max=0.0d0
 546       gcorr6_turn_max=0.0d0
 547       gsccorc_max=0.0d0
 548       gscloc_max=0.0d0
 549       gvdwx_max=0.0d0
 550       gradx_scp_max=0.0d0
 551       ghpbx_max=0.0d0
 552       gradxorr_max=0.0d0
 553       gsccorx_max=0.0d0
 554       gsclocx_max=0.0d0
 555       do i=1,nct
 556         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 557         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 558         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 559         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 560      &   gvdwc_scp_max=gvdwc_scp_norm
 561         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 562         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 563         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 564         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 565         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 566         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 567         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 568         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 569         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 570         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 571         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 572         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 573         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 574      &    gcorr3_turn(1,i)))
 575         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 576      &    gcorr3_turn_max=gcorr3_turn_norm
 577         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 578      &    gcorr4_turn(1,i)))
 579         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 580      &    gcorr4_turn_max=gcorr4_turn_norm
 581         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 582         if (gradcorr5_norm.gt.gradcorr5_max)
 583      &    gradcorr5_max=gradcorr5_norm
 584         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 585         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 586         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 587      &    gcorr6_turn(1,i)))
 588         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 589      &    gcorr6_turn_max=gcorr6_turn_norm
 590         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 591         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 592         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 593         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 594         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 595         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 596         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 597         if (gradx_scp_norm.gt.gradx_scp_max)
 598      &    gradx_scp_max=gradx_scp_norm
 599         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 600         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 601         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 602         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 603         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 604         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 605         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 606         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 607       enddo
 608       if (gradout) then
 609 #ifdef AIX
 610         open(istat,file=statname,position="append")
 611 #else
 612         open(istat,file=statname,access="append")
 613 #endif
 614         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 615      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 616      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 617      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 618      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 619      &     gsccorx_max,gsclocx_max
 620         close(istat)
 621         if (gvdwc_max.gt.1.0d4) then
 622           write (iout,*) "gvdwc gvdwx gradb gradbx"
 623           do i=nnt,nct
 624             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 625      &        gradb(j,i),gradbx(j,i),j=1,3)
 626           enddo
 627           call pdbout(0.0d0,'cipiszcze',iout)
 628           call flush(iout)
 629         endif
 630       endif
 631       endif
 632 #ifdef DEBUG
 633       write (iout,*) "gradc gradx gloc"
 634       do i=1,nres
 635         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 636      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 637       enddo
 638 #endif
 639       return
 640       end
 641 c-------------------------------------------------------------------------------
 642       subroutine rescale_weights(t_bath)
 643       implicit real*8 (a-h,o-z)
 644       include 'DIMENSIONS'
 645       include 'COMMON.IOUNITS'
 646       include 'COMMON.FFIELD'
 647       include 'COMMON.SBRIDGE'
 648       double precision kfac /2.4d0/
 649       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 650 c      facT=temp0/t_bath
 651 c      facT=2*temp0/(t_bath+temp0)
 652       if (rescale_mode.eq.0) then
 653         facT=1.0d0
 654         facT2=1.0d0
 655         facT3=1.0d0
 656         facT4=1.0d0
 657         facT5=1.0d0
 658       else if (rescale_mode.eq.1) then
 659         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 660         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 661         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 662         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 663         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 664       else if (rescale_mode.eq.2) then
 665         x=t_bath/temp0
 666         x2=x*x
 667         x3=x2*x
 668         x4=x3*x
 669         x5=x4*x
 670         facT=licznik/dlog(dexp(x)+dexp(-x))
 671         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 672         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 673         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 674         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 675       else
 676         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 677         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 678 #ifdef MPI
 679        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 680 #endif
 681        stop 555
 682       endif
 683       welec=weights(3)*fact
 684       wcorr=weights(4)*fact3
 685       wcorr5=weights(5)*fact4
 686       wcorr6=weights(6)*fact5
 687       wel_loc=weights(7)*fact2
 688       wturn3=weights(8)*fact2
 689       wturn4=weights(9)*fact3
 690       wturn6=weights(10)*fact5
 691       wtor=weights(13)*fact
 692       wtor_d=weights(14)*fact2
 693       wsccor=weights(21)*fact
 694
 695       return
 696       end
 697 C------------------------------------------------------------------------
 698       subroutine enerprint(energia)
 699       implicit real*8 (a-h,o-z)
 700       include 'DIMENSIONS'
 701       include 'COMMON.IOUNITS'
 702       include 'COMMON.FFIELD'
 703       include 'COMMON.SBRIDGE'
 704       include 'COMMON.MD'
 705       double precision energia(0:n_ene)
 706       etot=energia(0)
 707       evdw=energia(1)
 708       evdw2=energia(2)
 709 #ifdef SCP14
 710       evdw2=energia(2)+energia(18)
 711 #else
 712       evdw2=energia(2)
 713 #endif
 714       ees=energia(3)
 715 #ifdef SPLITELE
 716       evdw1=energia(16)
 717 #endif
 718       ecorr=energia(4)
 719       ecorr5=energia(5)
 720       ecorr6=energia(6)
 721       eel_loc=energia(7)
 722       eello_turn3=energia(8)
 723       eello_turn4=energia(9)
 724       eello_turn6=energia(10)
 725       ebe=energia(11)
 726       escloc=energia(12)
 727       etors=energia(13)
 728       etors_d=energia(14)
 729       ehpb=energia(15)
 730       edihcnstr=energia(19)
 731       estr=energia(17)
 732       Uconst=energia(20)
 733       esccor=energia(21)
 734 #ifdef SPLITELE
 735       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 736      &  estr,wbond,ebe,wang,
 737      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 738      &  ecorr,wcorr,
 739      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 740      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 741      &  edihcnstr,ebr*nss,
 742      &  Uconst,etot
 743    10 format (/'Virtual-chain energies:'//
 744      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 745      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 746      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 747      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 748      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 749      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 750      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 751      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 752      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 753      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 754      & ' (SS bridges & dist. cnstr.)'/
 755      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 756      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 757      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 758      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 759      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 760      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 761      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 762      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 763      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 764      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 765      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
 766      & 'ETOT=  ',1pE16.6,' (total)')
 767 #else
 768       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
 769      &  estr,wbond,ebe,wang,
 770      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 771      &  ecorr,wcorr,
 772      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 773      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
 774      &  ebr*nss,Uconst,etot
 775    10 format (/'Virtual-chain energies:'//
 776      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 777      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 778      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 779      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 780      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 781      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 782      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 783      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 784      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 785      & ' (SS bridges & dist. cnstr.)'/
 786      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 787      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 788      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 789      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 790      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 791      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 792      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 793      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 794      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 795      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 796      & 'UCONST=',1pE16.6,' (Constraint energy)'/
 797      & 'ETOT=  ',1pE16.6,' (total)')
 798 #endif
 799       return
 800       end
 801 C-----------------------------------------------------------------------
 802       subroutine elj(evdw)
 803 C
 804 C This subroutine calculates the interaction energy of nonbonded side chains
 805 C assuming the LJ potential of interaction.
 806 C
 807       implicit real*8 (a-h,o-z)
 808       include 'DIMENSIONS'
 809       parameter (accur=1.0d-10)
 810       include 'COMMON.GEO'
 811       include 'COMMON.VAR'
 812       include 'COMMON.LOCAL'
 813       include 'COMMON.CHAIN'
 814       include 'COMMON.DERIV'
 815       include 'COMMON.INTERACT'
 816       include 'COMMON.TORSION'
 817       include 'COMMON.SBRIDGE'
 818       include 'COMMON.NAMES'
 819       include 'COMMON.IOUNITS'
 820       include 'COMMON.CONTACTS'
 821       dimension gg(3)
 822 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 823       evdw=0.0D0
 824       do i=iatsc_s,iatsc_e
 825         itypi=itype(i)
 826         itypi1=itype(i+1)
 827         xi=c(1,nres+i)
 828         yi=c(2,nres+i)
 829         zi=c(3,nres+i)
 830 C Change 12/1/95
 831         num_conti=0
 832 C
 833 C Calculate SC interaction energy.
 834 C
 835         do iint=1,nint_gr(i)
 836 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 837 cd   &                  'iend=',iend(i,iint)
 838           do j=istart(i,iint),iend(i,iint)
 839             itypj=itype(j)
 840             xj=c(1,nres+j)-xi
 841             yj=c(2,nres+j)-yi
 842             zj=c(3,nres+j)-zi
 843 C Change 12/1/95 to calculate four-body interactions
 844             rij=xj*xj+yj*yj+zj*zj
 845             rrij=1.0D0/rij
 846 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 847             eps0ij=eps(itypi,itypj)
 848             fac=rrij**expon2
 849             e1=fac*fac*aa(itypi,itypj)
 850             e2=fac*bb(itypi,itypj)
 851             evdwij=e1+e2
 852 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 853 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 854 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 855 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 856 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 857 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 858             evdw=evdw+evdwij
 859 C
 860 C Calculate the components of the gradient in DC and X
 861 C
 862             fac=-rrij*(e1+evdwij)
 863             gg(1)=xj*fac
 864             gg(2)=yj*fac
 865             gg(3)=zj*fac
 866             do k=1,3
 867               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 868               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 869             enddo
 870             do k=i,j-1
 871               do l=1,3
 872                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 873               enddo
 874             enddo
 875 C
 876 C 12/1/95, revised on 5/20/97
 877 C
 878 C Calculate the contact function. The ith column of the array JCONT will
 879 C contain the numbers of atoms that make contacts with the atom I (of numbers
 880 C greater than I). The arrays FACONT and GACONT will contain the values of
 881 C the contact function and its derivative.
 882 C
 883 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 884 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 885 C Uncomment next line, if the correlation interactions are contact function only
 886             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 887               rij=dsqrt(rij)
 888               sigij=sigma(itypi,itypj)
 889               r0ij=rs0(itypi,itypj)
 890 C
 891 C Check whether the SC's are not too far to make a contact.
 892 C
 893               rcut=1.5d0*r0ij
 894               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 895 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 896 C
 897               if (fcont.gt.0.0D0) then
 898 C If the SC-SC distance if close to sigma, apply spline.
 899 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 900 cAdam &             fcont1,fprimcont1)
 901 cAdam           fcont1=1.0d0-fcont1
 902 cAdam           if (fcont1.gt.0.0d0) then
 903 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 904 cAdam             fcont=fcont*fcont1
 905 cAdam           endif
 906 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 907 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 908 cga             do k=1,3
 909 cga               gg(k)=gg(k)*eps0ij
 910 cga             enddo
 911 cga             eps0ij=-evdwij*eps0ij
 912 C Uncomment for AL's type of SC correlation interactions.
 913 cadam           eps0ij=-evdwij
 914                 num_conti=num_conti+1
 915                 jcont(num_conti,i)=j
 916                 facont(num_conti,i)=fcont*eps0ij
 917                 fprimcont=eps0ij*fprimcont/rij
 918                 fcont=expon*fcont
 919 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 920 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 921 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 922 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 923                 gacont(1,num_conti,i)=-fprimcont*xj
 924                 gacont(2,num_conti,i)=-fprimcont*yj
 925                 gacont(3,num_conti,i)=-fprimcont*zj
 926 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 927 cd              write (iout,'(2i3,3f10.5)')
 928 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 929               endif
 930             endif
 931           enddo      ! j
 932         enddo        ! iint
 933 C Change 12/1/95
 934         num_cont(i)=num_conti
 935       enddo          ! i
 936       do i=1,nct
 937         do j=1,3
 938           gvdwc(j,i)=expon*gvdwc(j,i)
 939           gvdwx(j,i)=expon*gvdwx(j,i)
 940         enddo
 941       enddo
 942 C******************************************************************************
 943 C
 944 C                              N O T E !!!
 945 C
 946 C To save time, the factor of EXPON has been extracted from ALL components
 947 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 948 C use!
 949 C
 950 C******************************************************************************
 951       return
 952       end
 953 C-----------------------------------------------------------------------------
 954       subroutine eljk(evdw)
 955 C
 956 C This subroutine calculates the interaction energy of nonbonded side chains
 957 C assuming the LJK potential of interaction.
 958 C
 959       implicit real*8 (a-h,o-z)
 960       include 'DIMENSIONS'
 961       include 'COMMON.GEO'
 962       include 'COMMON.VAR'
 963       include 'COMMON.LOCAL'
 964       include 'COMMON.CHAIN'
 965       include 'COMMON.DERIV'
 966       include 'COMMON.INTERACT'
 967       include 'COMMON.IOUNITS'
 968       include 'COMMON.NAMES'
 969       dimension gg(3)
 970       logical scheck
 971 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 972       evdw=0.0D0
 973       do i=iatsc_s,iatsc_e
 974         itypi=itype(i)
 975         itypi1=itype(i+1)
 976         xi=c(1,nres+i)
 977         yi=c(2,nres+i)
 978         zi=c(3,nres+i)
 979 C
 980 C Calculate SC interaction energy.
 981 C
 982         do iint=1,nint_gr(i)
 983           do j=istart(i,iint),iend(i,iint)
 984             itypj=itype(j)
 985             xj=c(1,nres+j)-xi
 986             yj=c(2,nres+j)-yi
 987             zj=c(3,nres+j)-zi
 988             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 989             fac_augm=rrij**expon
 990             e_augm=augm(itypi,itypj)*fac_augm
 991             r_inv_ij=dsqrt(rrij)
 992             rij=1.0D0/r_inv_ij
 993             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 994             fac=r_shift_inv**expon
 995             e1=fac*fac*aa(itypi,itypj)
 996             e2=fac*bb(itypi,itypj)
 997             evdwij=e_augm+e1+e2
 998 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 999 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1000 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1001 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1002 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1003 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1004 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1005             evdw=evdw+evdwij
1006 C
1007 C Calculate the components of the gradient in DC and X
1008 C
1009             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1010             gg(1)=xj*fac
1011             gg(2)=yj*fac
1012             gg(3)=zj*fac
1013             do k=1,3
1014               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1015               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1016             enddo
1017             do k=i,j-1
1018               do l=1,3
1019                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
1020               enddo
1021             enddo
1022           enddo      ! j
1023         enddo        ! iint
1024       enddo          ! i
1025       do i=1,nct
1026         do j=1,3
1027           gvdwc(j,i)=expon*gvdwc(j,i)
1028           gvdwx(j,i)=expon*gvdwx(j,i)
1029         enddo
1030       enddo
1031       return
1032       end
1033 C-----------------------------------------------------------------------------
1034       subroutine ebp(evdw)
1035 C
1036 C This subroutine calculates the interaction energy of nonbonded side chains
1037 C assuming the Berne-Pechukas potential of interaction.
1038 C
1039       implicit real*8 (a-h,o-z)
1040       include 'DIMENSIONS'
1041       include 'COMMON.GEO'
1042       include 'COMMON.VAR'
1043       include 'COMMON.LOCAL'
1044       include 'COMMON.CHAIN'
1045       include 'COMMON.DERIV'
1046       include 'COMMON.NAMES'
1047       include 'COMMON.INTERACT'
1048       include 'COMMON.IOUNITS'
1049       include 'COMMON.CALC'
1050       common /srutu/ icall
1051 c     double precision rrsave(maxdim)
1052       logical lprn
1053       evdw=0.0D0
1054 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1055       evdw=0.0D0
1056 c     if (icall.eq.0) then
1057 c       lprn=.true.
1058 c     else
1059         lprn=.false.
1060 c     endif
1061       ind=0
1062       do i=iatsc_s,iatsc_e
1063         itypi=itype(i)
1064         itypi1=itype(i+1)
1065         xi=c(1,nres+i)
1066         yi=c(2,nres+i)
1067         zi=c(3,nres+i)
1068         dxi=dc_norm(1,nres+i)
1069         dyi=dc_norm(2,nres+i)
1070         dzi=dc_norm(3,nres+i)
1071 c        dsci_inv=dsc_inv(itypi)
1072         dsci_inv=vbld_inv(i+nres)
1073 C
1074 C Calculate SC interaction energy.
1075 C
1076         do iint=1,nint_gr(i)
1077           do j=istart(i,iint),iend(i,iint)
1078             ind=ind+1
1079             itypj=itype(j)
1080 c            dscj_inv=dsc_inv(itypj)
1081             dscj_inv=vbld_inv(j+nres)
1082             chi1=chi(itypi,itypj)
1083             chi2=chi(itypj,itypi)
1084             chi12=chi1*chi2
1085             chip1=chip(itypi)
1086             chip2=chip(itypj)
1087             chip12=chip1*chip2
1088             alf1=alp(itypi)
1089             alf2=alp(itypj)
1090             alf12=0.5D0*(alf1+alf2)
1091 C For diagnostics only!!!
1092 c           chi1=0.0D0
1093 c           chi2=0.0D0
1094 c           chi12=0.0D0
1095 c           chip1=0.0D0
1096 c           chip2=0.0D0
1097 c           chip12=0.0D0
1098 c           alf1=0.0D0
1099 c           alf2=0.0D0
1100 c           alf12=0.0D0
1101             xj=c(1,nres+j)-xi
1102             yj=c(2,nres+j)-yi
1103             zj=c(3,nres+j)-zi
1104             dxj=dc_norm(1,nres+j)
1105             dyj=dc_norm(2,nres+j)
1106             dzj=dc_norm(3,nres+j)
1107             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1108 cd          if (icall.eq.0) then
1109 cd            rrsave(ind)=rrij
1110 cd          else
1111 cd            rrij=rrsave(ind)
1112 cd          endif
1113             rij=dsqrt(rrij)
1114 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1115             call sc_angular
1116 C Calculate whole angle-dependent part of epsilon and contributions
1117 C to its derivatives
1118             fac=(rrij*sigsq)**expon2
1119             e1=fac*fac*aa(itypi,itypj)
1120             e2=fac*bb(itypi,itypj)
1121             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1122             eps2der=evdwij*eps3rt
1123             eps3der=evdwij*eps2rt
1124             evdwij=evdwij*eps2rt*eps3rt
1125             evdw=evdw+evdwij
1126             if (lprn) then
1127             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1128             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1129 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1130 cd     &        restyp(itypi),i,restyp(itypj),j,
1131 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1132 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1133 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1134 cd     &        evdwij
1135             endif
1136 C Calculate gradient components.
1137             e1=e1*eps1*eps2rt**2*eps3rt**2
1138             fac=-expon*(e1+evdwij)
1139             sigder=fac/sigsq
1140             fac=rrij*fac
1141 C Calculate radial part of the gradient
1142             gg(1)=xj*fac
1143             gg(2)=yj*fac
1144             gg(3)=zj*fac
1145 C Calculate the angular part of the gradient and sum add the contributions
1146 C to the appropriate components of the Cartesian gradient.
1147             call sc_grad
1148           enddo      ! j
1149         enddo        ! iint
1150       enddo          ! i
1151 c     stop
1152       return
1153       end
1154 C-----------------------------------------------------------------------------
1155       subroutine egb(evdw)
1156 C
1157 C This subroutine calculates the interaction energy of nonbonded side chains
1158 C assuming the Gay-Berne potential of interaction.
1159 C
1160       implicit real*8 (a-h,o-z)
1161       include 'DIMENSIONS'
1162       include 'COMMON.GEO'
1163       include 'COMMON.VAR'
1164       include 'COMMON.LOCAL'
1165       include 'COMMON.CHAIN'
1166       include 'COMMON.DERIV'
1167       include 'COMMON.NAMES'
1168       include 'COMMON.INTERACT'
1169       include 'COMMON.IOUNITS'
1170       include 'COMMON.CALC'
1171       include 'COMMON.CONTROL'
1172       logical lprn
1173       evdw=0.0D0
1174 ccccc      energy_dec=.false.
1175 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1176       evdw=0.0D0
1177       lprn=.false.
1178 c     if (icall.eq.0) lprn=.false.
1179       ind=0
1180       do i=iatsc_s,iatsc_e
1181         itypi=itype(i)
1182         itypi1=itype(i+1)
1183         xi=c(1,nres+i)
1184         yi=c(2,nres+i)
1185         zi=c(3,nres+i)
1186         dxi=dc_norm(1,nres+i)
1187         dyi=dc_norm(2,nres+i)
1188         dzi=dc_norm(3,nres+i)
1189 c        dsci_inv=dsc_inv(itypi)
1190         dsci_inv=vbld_inv(i+nres)
1191 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1192 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1193 C
1194 C Calculate SC interaction energy.
1195 C
1196         do iint=1,nint_gr(i)
1197           do j=istart(i,iint),iend(i,iint)
1198             ind=ind+1
1199             itypj=itype(j)
1200 c            dscj_inv=dsc_inv(itypj)
1201             dscj_inv=vbld_inv(j+nres)
1202 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1203 c     &       1.0d0/vbld(j+nres)
1204 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1205             sig0ij=sigma(itypi,itypj)
1206             chi1=chi(itypi,itypj)
1207             chi2=chi(itypj,itypi)
1208             chi12=chi1*chi2
1209             chip1=chip(itypi)
1210             chip2=chip(itypj)
1211             chip12=chip1*chip2
1212             alf1=alp(itypi)
1213             alf2=alp(itypj)
1214             alf12=0.5D0*(alf1+alf2)
1215 C For diagnostics only!!!
1216 c           chi1=0.0D0
1217 c           chi2=0.0D0
1218 c           chi12=0.0D0
1219 c           chip1=0.0D0
1220 c           chip2=0.0D0
1221 c           chip12=0.0D0
1222 c           alf1=0.0D0
1223 c           alf2=0.0D0
1224 c           alf12=0.0D0
1225             xj=c(1,nres+j)-xi
1226             yj=c(2,nres+j)-yi
1227             zj=c(3,nres+j)-zi
1228             dxj=dc_norm(1,nres+j)
1229             dyj=dc_norm(2,nres+j)
1230             dzj=dc_norm(3,nres+j)
1231 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1232 c            write (iout,*) "j",j," dc_norm",
1233 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1234             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1235             rij=dsqrt(rrij)
1236 C Calculate angle-dependent terms of energy and contributions to their
1237 C derivatives.
1238             call sc_angular
1239             sigsq=1.0D0/sigsq
1240             sig=sig0ij*dsqrt(sigsq)
1241             rij_shift=1.0D0/rij-sig+sig0ij
1242 c for diagnostics; uncomment
1243 c            rij_shift=1.2*sig0ij
1244 C I hate to put IF's in the loops, but here don't have another choice!!!!
1245             if (rij_shift.le.0.0D0) then
1246               evdw=1.0D20
1247 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1248 cd     &        restyp(itypi),i,restyp(itypj),j,
1249 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1250               return
1251             endif
1252             sigder=-sig*sigsq
1253 c---------------------------------------------------------------
1254             rij_shift=1.0D0/rij_shift
1255             fac=rij_shift**expon
1256             e1=fac*fac*aa(itypi,itypj)
1257             e2=fac*bb(itypi,itypj)
1258             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1259             eps2der=evdwij*eps3rt
1260             eps3der=evdwij*eps2rt
1261 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1262 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1263             evdwij=evdwij*eps2rt*eps3rt
1264             evdw=evdw+evdwij
1265             if (lprn) then
1266             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1267             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1268             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1269      &        restyp(itypi),i,restyp(itypj),j,
1270      &        epsi,sigm,chi1,chi2,chip1,chip2,
1271      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1272      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1273      &        evdwij
1274             endif
1275
1276             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1277      &                        'evdw',i,j,evdwij
1278
1279 C Calculate gradient components.
1280             e1=e1*eps1*eps2rt**2*eps3rt**2
1281             fac=-expon*(e1+evdwij)*rij_shift
1282             sigder=fac*sigder
1283             fac=rij*fac
1284 c            fac=0.0d0
1285 C Calculate the radial part of the gradient
1286             gg(1)=xj*fac
1287             gg(2)=yj*fac
1288             gg(3)=zj*fac
1289 C Calculate angular part of the gradient.
1290             call sc_grad
1291           enddo      ! j
1292         enddo        ! iint
1293       enddo          ! i
1294 c      write (iout,*) "Number of loop steps in EGB:",ind
1295 cccc      energy_dec=.false.
1296       return
1297       end
1298 C-----------------------------------------------------------------------------
1299       subroutine egbv(evdw)
1300 C
1301 C This subroutine calculates the interaction energy of nonbonded side chains
1302 C assuming the Gay-Berne-Vorobjev potential of interaction.
1303 C
1304       implicit real*8 (a-h,o-z)
1305       include 'DIMENSIONS'
1306       include 'COMMON.GEO'
1307       include 'COMMON.VAR'
1308       include 'COMMON.LOCAL'
1309       include 'COMMON.CHAIN'
1310       include 'COMMON.DERIV'
1311       include 'COMMON.NAMES'
1312       include 'COMMON.INTERACT'
1313       include 'COMMON.IOUNITS'
1314       include 'COMMON.CALC'
1315       common /srutu/ icall
1316       logical lprn
1317       evdw=0.0D0
1318 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1319       evdw=0.0D0
1320       lprn=.false.
1321 c     if (icall.eq.0) lprn=.true.
1322       ind=0
1323       do i=iatsc_s,iatsc_e
1324         itypi=itype(i)
1325         itypi1=itype(i+1)
1326         xi=c(1,nres+i)
1327         yi=c(2,nres+i)
1328         zi=c(3,nres+i)
1329         dxi=dc_norm(1,nres+i)
1330         dyi=dc_norm(2,nres+i)
1331         dzi=dc_norm(3,nres+i)
1332 c        dsci_inv=dsc_inv(itypi)
1333         dsci_inv=vbld_inv(i+nres)
1334 C
1335 C Calculate SC interaction energy.
1336 C
1337         do iint=1,nint_gr(i)
1338           do j=istart(i,iint),iend(i,iint)
1339             ind=ind+1
1340             itypj=itype(j)
1341 c            dscj_inv=dsc_inv(itypj)
1342             dscj_inv=vbld_inv(j+nres)
1343             sig0ij=sigma(itypi,itypj)
1344             r0ij=r0(itypi,itypj)
1345             chi1=chi(itypi,itypj)
1346             chi2=chi(itypj,itypi)
1347             chi12=chi1*chi2
1348             chip1=chip(itypi)
1349             chip2=chip(itypj)
1350             chip12=chip1*chip2
1351             alf1=alp(itypi)
1352             alf2=alp(itypj)
1353             alf12=0.5D0*(alf1+alf2)
1354 C For diagnostics only!!!
1355 c           chi1=0.0D0
1356 c           chi2=0.0D0
1357 c           chi12=0.0D0
1358 c           chip1=0.0D0
1359 c           chip2=0.0D0
1360 c           chip12=0.0D0
1361 c           alf1=0.0D0
1362 c           alf2=0.0D0
1363 c           alf12=0.0D0
1364             xj=c(1,nres+j)-xi
1365             yj=c(2,nres+j)-yi
1366             zj=c(3,nres+j)-zi
1367             dxj=dc_norm(1,nres+j)
1368             dyj=dc_norm(2,nres+j)
1369             dzj=dc_norm(3,nres+j)
1370             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1371             rij=dsqrt(rrij)
1372 C Calculate angle-dependent terms of energy and contributions to their
1373 C derivatives.
1374             call sc_angular
1375             sigsq=1.0D0/sigsq
1376             sig=sig0ij*dsqrt(sigsq)
1377             rij_shift=1.0D0/rij-sig+r0ij
1378 C I hate to put IF's in the loops, but here don't have another choice!!!!
1379             if (rij_shift.le.0.0D0) then
1380               evdw=1.0D20
1381               return
1382             endif
1383             sigder=-sig*sigsq
1384 c---------------------------------------------------------------
1385             rij_shift=1.0D0/rij_shift
1386             fac=rij_shift**expon
1387             e1=fac*fac*aa(itypi,itypj)
1388             e2=fac*bb(itypi,itypj)
1389             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1390             eps2der=evdwij*eps3rt
1391             eps3der=evdwij*eps2rt
1392             fac_augm=rrij**expon
1393             e_augm=augm(itypi,itypj)*fac_augm
1394             evdwij=evdwij*eps2rt*eps3rt
1395             evdw=evdw+evdwij+e_augm
1396             if (lprn) then
1397             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1398             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1399             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1400      &        restyp(itypi),i,restyp(itypj),j,
1401      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1402      &        chi1,chi2,chip1,chip2,
1403      &        eps1,eps2rt**2,eps3rt**2,
1404      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1405      &        evdwij+e_augm
1406             endif
1407 C Calculate gradient components.
1408             e1=e1*eps1*eps2rt**2*eps3rt**2
1409             fac=-expon*(e1+evdwij)*rij_shift
1410             sigder=fac*sigder
1411             fac=rij*fac-2*expon*rrij*e_augm
1412 C Calculate the radial part of the gradient
1413             gg(1)=xj*fac
1414             gg(2)=yj*fac
1415             gg(3)=zj*fac
1416 C Calculate angular part of the gradient.
1417             call sc_grad
1418           enddo      ! j
1419         enddo        ! iint
1420       enddo          ! i
1421       end
1422 C-----------------------------------------------------------------------------
1423       subroutine sc_angular
1424 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1425 C om12. Called by ebp, egb, and egbv.
1426       implicit none
1427       include 'COMMON.CALC'
1428       include 'COMMON.IOUNITS'
1429       erij(1)=xj*rij
1430       erij(2)=yj*rij
1431       erij(3)=zj*rij
1432       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1433       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1434       om12=dxi*dxj+dyi*dyj+dzi*dzj
1435       chiom12=chi12*om12
1436 C Calculate eps1(om12) and its derivative in om12
1437       faceps1=1.0D0-om12*chiom12
1438       faceps1_inv=1.0D0/faceps1
1439       eps1=dsqrt(faceps1_inv)
1440 C Following variable is eps1*deps1/dom12
1441       eps1_om12=faceps1_inv*chiom12
1442 c diagnostics only
1443 c      faceps1_inv=om12
1444 c      eps1=om12
1445 c      eps1_om12=1.0d0
1446 c      write (iout,*) "om12",om12," eps1",eps1
1447 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1448 C and om12.
1449       om1om2=om1*om2
1450       chiom1=chi1*om1
1451       chiom2=chi2*om2
1452       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1453       sigsq=1.0D0-facsig*faceps1_inv
1454       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1455       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1456       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1457 c diagnostics only
1458 c      sigsq=1.0d0
1459 c      sigsq_om1=0.0d0
1460 c      sigsq_om2=0.0d0
1461 c      sigsq_om12=0.0d0
1462 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1463 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1464 c     &    " eps1",eps1
1465 C Calculate eps2 and its derivatives in om1, om2, and om12.
1466       chipom1=chip1*om1
1467       chipom2=chip2*om2
1468       chipom12=chip12*om12
1469       facp=1.0D0-om12*chipom12
1470       facp_inv=1.0D0/facp
1471       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1472 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1473 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1474 C Following variable is the square root of eps2
1475       eps2rt=1.0D0-facp1*facp_inv
1476 C Following three variables are the derivatives of the square root of eps
1477 C in om1, om2, and om12.
1478       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1479       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1480       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1481 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1482       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1483 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1484 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1485 c     &  " eps2rt_om12",eps2rt_om12
1486 C Calculate whole angle-dependent part of epsilon and contributions
1487 C to its derivatives
1488       return
1489       end
1490 C----------------------------------------------------------------------------
1491       subroutine sc_grad
1492       implicit real*8 (a-h,o-z)
1493       include 'DIMENSIONS'
1494       include 'COMMON.CHAIN'
1495       include 'COMMON.DERIV'
1496       include 'COMMON.CALC'
1497       include 'COMMON.IOUNITS'
1498       double precision dcosom1(3),dcosom2(3)
1499       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1500       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1501       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1502      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1503 c diagnostics only
1504 c      eom1=0.0d0
1505 c      eom2=0.0d0
1506 c      eom12=evdwij*eps1_om12
1507 c end diagnostics
1508 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1509 c     &  " sigder",sigder
1510 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1511 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1512       do k=1,3
1513         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1514         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1515       enddo
1516       do k=1,3
1517         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1518       enddo
1519 c      write (iout,*) "gg",(gg(k),k=1,3)
1520       do k=1,3
1521         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1522      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1523      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1524         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1525      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1526      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1527 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1528 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1529 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1530 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1531       enddo
1532 C
1533 C Calculate the components of the gradient in DC and X
1534 C
1535 c      do k=i,j-1
1536 c        do l=1,3
1537 c          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1538 c        enddo
1539 c      enddo
1540       return
1541       end
1542 C-----------------------------------------------------------------------
1543       subroutine e_softsphere(evdw)
1544 C
1545 C This subroutine calculates the interaction energy of nonbonded side chains
1546 C assuming the LJ potential of interaction.
1547 C
1548       implicit real*8 (a-h,o-z)
1549       include 'DIMENSIONS'
1550       parameter (accur=1.0d-10)
1551       include 'COMMON.GEO'
1552       include 'COMMON.VAR'
1553       include 'COMMON.LOCAL'
1554       include 'COMMON.CHAIN'
1555       include 'COMMON.DERIV'
1556       include 'COMMON.INTERACT'
1557       include 'COMMON.TORSION'
1558       include 'COMMON.SBRIDGE'
1559       include 'COMMON.NAMES'
1560       include 'COMMON.IOUNITS'
1561       include 'COMMON.CONTACTS'
1562       dimension gg(3)
1563 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1564       evdw=0.0D0
1565       do i=iatsc_s,iatsc_e
1566         itypi=itype(i)
1567         itypi1=itype(i+1)
1568         xi=c(1,nres+i)
1569         yi=c(2,nres+i)
1570         zi=c(3,nres+i)
1571 C
1572 C Calculate SC interaction energy.
1573 C
1574         do iint=1,nint_gr(i)
1575 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1576 cd   &                  'iend=',iend(i,iint)
1577           do j=istart(i,iint),iend(i,iint)
1578             itypj=itype(j)
1579             xj=c(1,nres+j)-xi
1580             yj=c(2,nres+j)-yi
1581             zj=c(3,nres+j)-zi
1582             rij=xj*xj+yj*yj+zj*zj
1583 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1584             r0ij=r0(itypi,itypj)
1585             r0ijsq=r0ij*r0ij
1586 c            print *,i,j,r0ij,dsqrt(rij)
1587             if (rij.lt.r0ijsq) then
1588               evdwij=0.25d0*(rij-r0ijsq)**2
1589               fac=rij-r0ijsq
1590             else
1591               evdwij=0.0d0
1592               fac=0.0d0
1593             endif
1594             evdw=evdw+evdwij
1595 C
1596 C Calculate the components of the gradient in DC and X
1597 C
1598             gg(1)=xj*fac
1599             gg(2)=yj*fac
1600             gg(3)=zj*fac
1601             do k=1,3
1602               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1603               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1604             enddo
1605             do k=i,j-1
1606               do l=1,3
1607                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
1608               enddo
1609             enddo
1610           enddo ! j
1611         enddo ! iint
1612       enddo ! i
1613       return
1614       end
1615 C--------------------------------------------------------------------------
1616       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1617      &              eello_turn4)
1618 C
1619 C Soft-sphere potential of p-p interaction
1620 C
1621       implicit real*8 (a-h,o-z)
1622       include 'DIMENSIONS'
1623       include 'COMMON.CONTROL'
1624       include 'COMMON.IOUNITS'
1625       include 'COMMON.GEO'
1626       include 'COMMON.VAR'
1627       include 'COMMON.LOCAL'
1628       include 'COMMON.CHAIN'
1629       include 'COMMON.DERIV'
1630       include 'COMMON.INTERACT'
1631       include 'COMMON.CONTACTS'
1632       include 'COMMON.TORSION'
1633       include 'COMMON.VECTORS'
1634       include 'COMMON.FFIELD'
1635       dimension ggg(3)
1636 cd      write(iout,*) 'In EELEC_soft_sphere'
1637       num_conti_hb=0
1638       ees=0.0D0
1639       evdw1=0.0D0
1640       eel_loc=0.0d0
1641       eello_turn3=0.0d0
1642       eello_turn4=0.0d0
1643       ind=0
1644       do i=iatel_s,iatel_e
1645         dxi=dc(1,i)
1646         dyi=dc(2,i)
1647         dzi=dc(3,i)
1648         xmedi=c(1,i)+0.5d0*dxi
1649         ymedi=c(2,i)+0.5d0*dyi
1650         zmedi=c(3,i)+0.5d0*dzi
1651         num_conti=0
1652 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1653         do j=ielstart(i),ielend(i)
1654           ind=ind+1
1655           iteli=itel(i)
1656           itelj=itel(j)
1657           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1658           r0ij=rpp(iteli,itelj)
1659           r0ijsq=r0ij*r0ij
1660           dxj=dc(1,j)
1661           dyj=dc(2,j)
1662           dzj=dc(3,j)
1663           xj=c(1,j)+0.5D0*dxj-xmedi
1664           yj=c(2,j)+0.5D0*dyj-ymedi
1665           zj=c(3,j)+0.5D0*dzj-zmedi
1666           rij=xj*xj+yj*yj+zj*zj
1667           if (rij.lt.r0ijsq) then
1668             evdw1ij=0.25d0*(rij-r0ijsq)**2
1669             fac=rij-r0ijsq
1670           else
1671             evdw1ij=0.0d0
1672             fac=0.0d0
1673           endif
1674           evdw1=evdw1+evdw1ij
1675 C
1676 C Calculate contributions to the Cartesian gradient.
1677 C
1678           ggg(1)=fac*xj
1679           ggg(2)=fac*yj
1680           ggg(3)=fac*zj
1681           do k=1,3
1682             ghalf=0.5D0*ggg(k)
1683             gelc(k,i)=gelc(k,i)+ghalf
1684             gelc(k,j)=gelc(k,j)+ghalf
1685           enddo
1686 *
1687 * Loop over residues i+1 thru j-1.
1688 *
1689           do k=i+1,j-1
1690             do l=1,3
1691               gelc(l,k)=gelc(l,k)+ggg(l)
1692             enddo
1693           enddo
1694         enddo ! j
1695       enddo   ! i
1696       return
1697       end
1698 c------------------------------------------------------------------------------
1699       subroutine vec_and_deriv
1700       implicit real*8 (a-h,o-z)
1701       include 'DIMENSIONS'
1702 #ifdef MPI
1703       include 'mpif.h'
1704 #endif
1705       include 'COMMON.IOUNITS'
1706       include 'COMMON.GEO'
1707       include 'COMMON.VAR'
1708       include 'COMMON.LOCAL'
1709       include 'COMMON.CHAIN'
1710       include 'COMMON.VECTORS'
1711       include 'COMMON.SETUP'
1712       include 'COMMON.TIME1'
1713       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1714 C Compute the local reference systems. For reference system (i), the
1715 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1716 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1717 c      do i=1,nres-1
1718       do i=ivec_start,ivec_end
1719           if (i.eq.nres-1) then
1720 C Case of the last full residue
1721 C Compute the Z-axis
1722             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1723             costh=dcos(pi-theta(nres))
1724             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1725             do k=1,3
1726               uz(k,i)=fac*uz(k,i)
1727             enddo
1728 C Compute the derivatives of uz
1729             uzder(1,1,1)= 0.0d0
1730             uzder(2,1,1)=-dc_norm(3,i-1)
1731             uzder(3,1,1)= dc_norm(2,i-1)
1732             uzder(1,2,1)= dc_norm(3,i-1)
1733             uzder(2,2,1)= 0.0d0
1734             uzder(3,2,1)=-dc_norm(1,i-1)
1735             uzder(1,3,1)=-dc_norm(2,i-1)
1736             uzder(2,3,1)= dc_norm(1,i-1)
1737             uzder(3,3,1)= 0.0d0
1738             uzder(1,1,2)= 0.0d0
1739             uzder(2,1,2)= dc_norm(3,i)
1740             uzder(3,1,2)=-dc_norm(2,i)
1741             uzder(1,2,2)=-dc_norm(3,i)
1742             uzder(2,2,2)= 0.0d0
1743             uzder(3,2,2)= dc_norm(1,i)
1744             uzder(1,3,2)= dc_norm(2,i)
1745             uzder(2,3,2)=-dc_norm(1,i)
1746             uzder(3,3,2)= 0.0d0
1747 C Compute the Y-axis
1748             facy=fac
1749             do k=1,3
1750               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1751             enddo
1752 C Compute the derivatives of uy
1753             do j=1,3
1754               do k=1,3
1755                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1756      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1757                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1758               enddo
1759               uyder(j,j,1)=uyder(j,j,1)-costh
1760               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1761             enddo
1762             do j=1,2
1763               do k=1,3
1764                 do l=1,3
1765                   uygrad(l,k,j,i)=uyder(l,k,j)
1766                   uzgrad(l,k,j,i)=uzder(l,k,j)
1767                 enddo
1768               enddo
1769             enddo
1770             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1771             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1772             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1773             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1774           else
1775 C Other residues
1776 C Compute the Z-axis
1777             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1778             costh=dcos(pi-theta(i+2))
1779             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1780             do k=1,3
1781               uz(k,i)=fac*uz(k,i)
1782             enddo
1783 C Compute the derivatives of uz
1784             uzder(1,1,1)= 0.0d0
1785             uzder(2,1,1)=-dc_norm(3,i+1)
1786             uzder(3,1,1)= dc_norm(2,i+1)
1787             uzder(1,2,1)= dc_norm(3,i+1)
1788             uzder(2,2,1)= 0.0d0
1789             uzder(3,2,1)=-dc_norm(1,i+1)
1790             uzder(1,3,1)=-dc_norm(2,i+1)
1791             uzder(2,3,1)= dc_norm(1,i+1)
1792             uzder(3,3,1)= 0.0d0
1793             uzder(1,1,2)= 0.0d0
1794             uzder(2,1,2)= dc_norm(3,i)
1795             uzder(3,1,2)=-dc_norm(2,i)
1796             uzder(1,2,2)=-dc_norm(3,i)
1797             uzder(2,2,2)= 0.0d0
1798             uzder(3,2,2)= dc_norm(1,i)
1799             uzder(1,3,2)= dc_norm(2,i)
1800             uzder(2,3,2)=-dc_norm(1,i)
1801             uzder(3,3,2)= 0.0d0
1802 C Compute the Y-axis
1803             facy=fac
1804             do k=1,3
1805               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1806             enddo
1807 C Compute the derivatives of uy
1808             do j=1,3
1809               do k=1,3
1810                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1811      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1812                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1813               enddo
1814               uyder(j,j,1)=uyder(j,j,1)-costh
1815               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1816             enddo
1817             do j=1,2
1818               do k=1,3
1819                 do l=1,3
1820                   uygrad(l,k,j,i)=uyder(l,k,j)
1821                   uzgrad(l,k,j,i)=uzder(l,k,j)
1822                 enddo
1823               enddo
1824             enddo
1825             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1826             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1827             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1828             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1829           endif
1830       enddo
1831       do i=1,nres-1
1832         vbld_inv_temp(1)=vbld_inv(i+1)
1833         if (i.lt.nres-1) then
1834           vbld_inv_temp(2)=vbld_inv(i+2)
1835           else
1836           vbld_inv_temp(2)=vbld_inv(i)
1837           endif
1838         do j=1,2
1839           do k=1,3
1840             do l=1,3
1841               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1842               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1843             enddo
1844           enddo
1845         enddo
1846       enddo
1847 #ifdef MPI
1848       if (nfgtasks.gt.1) then
1849         time00=MPI_Wtime()
1850 c        print *,"Processor",fg_rank,kolor," ivec_start",ivec_start,
1851 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
1852 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
1853         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank),
1854      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
1855      &   FG_COMM,IERR)
1856         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank),
1857      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
1858      &   FG_COMM,IERR)
1859         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
1860      &   ivec_count(fg_rank),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
1861      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM,IERR)
1862         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
1863      &   ivec_count(fg_rank),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
1864      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM,IERR)
1865         time_gather=time_gather+MPI_Wtime()-time00
1866       endif
1867 c      if (fg_rank.eq.0) then
1868 c        write (iout,*) "Arrays UY and UZ"
1869 c        do i=1,nres-1
1870 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
1871 c     &     (uz(k,i),k=1,3)
1872 c        enddo
1873 c      endif
1874 #endif
1875       return
1876       end
1877 C-----------------------------------------------------------------------------
1878       subroutine check_vecgrad
1879       implicit real*8 (a-h,o-z)
1880       include 'DIMENSIONS'
1881       include 'COMMON.IOUNITS'
1882       include 'COMMON.GEO'
1883       include 'COMMON.VAR'
1884       include 'COMMON.LOCAL'
1885       include 'COMMON.CHAIN'
1886       include 'COMMON.VECTORS'
1887       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1888       dimension uyt(3,maxres),uzt(3,maxres)
1889       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1890       double precision delta /1.0d-7/
1891       call vec_and_deriv
1892 cd      do i=1,nres
1893 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1894 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1895 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1896 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1897 cd     &     (dc_norm(if90,i),if90=1,3)
1898 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1899 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1900 cd          write(iout,'(a)')
1901 cd      enddo
1902       do i=1,nres
1903         do j=1,2
1904           do k=1,3
1905             do l=1,3
1906               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1907               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1908             enddo
1909           enddo
1910         enddo
1911       enddo
1912       call vec_and_deriv
1913       do i=1,nres
1914         do j=1,3
1915           uyt(j,i)=uy(j,i)
1916           uzt(j,i)=uz(j,i)
1917         enddo
1918       enddo
1919       do i=1,nres
1920 cd        write (iout,*) 'i=',i
1921         do k=1,3
1922           erij(k)=dc_norm(k,i)
1923         enddo
1924         do j=1,3
1925           do k=1,3
1926             dc_norm(k,i)=erij(k)
1927           enddo
1928           dc_norm(j,i)=dc_norm(j,i)+delta
1929 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1930 c          do k=1,3
1931 c            dc_norm(k,i)=dc_norm(k,i)/fac
1932 c          enddo
1933 c          write (iout,*) (dc_norm(k,i),k=1,3)
1934 c          write (iout,*) (erij(k),k=1,3)
1935           call vec_and_deriv
1936           do k=1,3
1937             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1938             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1939             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1940             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1941           enddo
1942 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1943 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1944 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1945         enddo
1946         do k=1,3
1947           dc_norm(k,i)=erij(k)
1948         enddo
1949 cd        do k=1,3
1950 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1951 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1952 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1953 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1954 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1955 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1956 cd          write (iout,'(a)')
1957 cd        enddo
1958       enddo
1959       return
1960       end
1961 C--------------------------------------------------------------------------
1962       subroutine set_matrices
1963       implicit real*8 (a-h,o-z)
1964       include 'DIMENSIONS'
1965       include 'COMMON.IOUNITS'
1966       include 'COMMON.GEO'
1967       include 'COMMON.VAR'
1968       include 'COMMON.LOCAL'
1969       include 'COMMON.CHAIN'
1970       include 'COMMON.DERIV'
1971       include 'COMMON.INTERACT'
1972       include 'COMMON.CONTACTS'
1973       include 'COMMON.TORSION'
1974       include 'COMMON.VECTORS'
1975       include 'COMMON.FFIELD'
1976       double precision auxvec(2),auxmat(2,2)
1977 C
1978 C Compute the virtual-bond-torsional-angle dependent quantities needed
1979 C to calculate the el-loc multibody terms of various order.
1980 C
1981       do i=3,nres+1
1982         if (i .lt. nres+1) then
1983           sin1=dsin(phi(i))
1984           cos1=dcos(phi(i))
1985           sintab(i-2)=sin1
1986           costab(i-2)=cos1
1987           obrot(1,i-2)=cos1
1988           obrot(2,i-2)=sin1
1989           sin2=dsin(2*phi(i))
1990           cos2=dcos(2*phi(i))
1991           sintab2(i-2)=sin2
1992           costab2(i-2)=cos2
1993           obrot2(1,i-2)=cos2
1994           obrot2(2,i-2)=sin2
1995           Ug(1,1,i-2)=-cos1
1996           Ug(1,2,i-2)=-sin1
1997           Ug(2,1,i-2)=-sin1
1998           Ug(2,2,i-2)= cos1
1999           Ug2(1,1,i-2)=-cos2
2000           Ug2(1,2,i-2)=-sin2
2001           Ug2(2,1,i-2)=-sin2
2002           Ug2(2,2,i-2)= cos2
2003         else
2004           costab(i-2)=1.0d0
2005           sintab(i-2)=0.0d0
2006           obrot(1,i-2)=1.0d0
2007           obrot(2,i-2)=0.0d0
2008           obrot2(1,i-2)=0.0d0
2009           obrot2(2,i-2)=0.0d0
2010           Ug(1,1,i-2)=1.0d0
2011           Ug(1,2,i-2)=0.0d0
2012           Ug(2,1,i-2)=0.0d0
2013           Ug(2,2,i-2)=1.0d0
2014           Ug2(1,1,i-2)=0.0d0
2015           Ug2(1,2,i-2)=0.0d0
2016           Ug2(2,1,i-2)=0.0d0
2017           Ug2(2,2,i-2)=0.0d0
2018         endif
2019         if (i .gt. 3 .and. i .lt. nres+1) then
2020           obrot_der(1,i-2)=-sin1
2021           obrot_der(2,i-2)= cos1
2022           Ugder(1,1,i-2)= sin1
2023           Ugder(1,2,i-2)=-cos1
2024           Ugder(2,1,i-2)=-cos1
2025           Ugder(2,2,i-2)=-sin1
2026           dwacos2=cos2+cos2
2027           dwasin2=sin2+sin2
2028           obrot2_der(1,i-2)=-dwasin2
2029           obrot2_der(2,i-2)= dwacos2
2030           Ug2der(1,1,i-2)= dwasin2
2031           Ug2der(1,2,i-2)=-dwacos2
2032           Ug2der(2,1,i-2)=-dwacos2
2033           Ug2der(2,2,i-2)=-dwasin2
2034         else
2035           obrot_der(1,i-2)=0.0d0
2036           obrot_der(2,i-2)=0.0d0
2037           Ugder(1,1,i-2)=0.0d0
2038           Ugder(1,2,i-2)=0.0d0
2039           Ugder(2,1,i-2)=0.0d0
2040           Ugder(2,2,i-2)=0.0d0
2041           obrot2_der(1,i-2)=0.0d0
2042           obrot2_der(2,i-2)=0.0d0
2043           Ug2der(1,1,i-2)=0.0d0
2044           Ug2der(1,2,i-2)=0.0d0
2045           Ug2der(2,1,i-2)=0.0d0
2046           Ug2der(2,2,i-2)=0.0d0
2047         endif
2048 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2049         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2050           iti = itortyp(itype(i-2))
2051         else
2052           iti=ntortyp+1
2053         endif
2054 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2055         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2056           iti1 = itortyp(itype(i-1))
2057         else
2058           iti1=ntortyp+1
2059         endif
2060 cd        write (iout,*) '*******i',i,' iti1',iti
2061 cd        write (iout,*) 'b1',b1(:,iti)
2062 cd        write (iout,*) 'b2',b2(:,iti)
2063 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2064 c        if (i .gt. iatel_s+2) then
2065         if (i .gt. nnt+2) then
2066           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2067           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2068           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2069           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2070           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2071           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2072           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2073         else
2074           do k=1,2
2075             Ub2(k,i-2)=0.0d0
2076             Ctobr(k,i-2)=0.0d0
2077             Dtobr2(k,i-2)=0.0d0
2078             do l=1,2
2079               EUg(l,k,i-2)=0.0d0
2080               CUg(l,k,i-2)=0.0d0
2081               DUg(l,k,i-2)=0.0d0
2082               DtUg2(l,k,i-2)=0.0d0
2083             enddo
2084           enddo
2085         endif
2086         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2087         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2088         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2089         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2090         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2091         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2092         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2093         do k=1,2
2094           muder(k,i-2)=Ub2der(k,i-2)
2095         enddo
2096 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2097         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2098           iti1 = itortyp(itype(i-1))
2099         else
2100           iti1=ntortyp+1
2101         endif
2102         do k=1,2
2103           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2104         enddo
2105 C Vectors and matrices dependent on a single virtual-bond dihedral.
2106         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2107         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2108         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2109         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2110         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2111         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2112         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2113         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2114         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2115 cd        write (iout,*) 'mu ',mu(:,i-2)
2116 cd        write (iout,*) 'mu1',mu1(:,i-2)
2117 cd        write (iout,*) 'mu2',mu2(:,i-2)
2118       enddo
2119 C Matrices dependent on two consecutive virtual-bond dihedrals.
2120 C The order of matrices is from left to right.
2121       do i=2,nres-1
2122         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2123         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2124         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2125         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2126         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2127         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2128         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2129         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2130       enddo
2131 cd      do i=1,nres
2132 cd        iti = itortyp(itype(i))
2133 cd        write (iout,*) i
2134 cd        do j=1,2
2135 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2136 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2137 cd        enddo
2138 cd      enddo
2139       return
2140       end
2141 C--------------------------------------------------------------------------
2142       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2143 C
2144 C This subroutine calculates the average interaction energy and its gradient
2145 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2146 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2147 C The potential depends both on the distance of peptide-group centers and on
2148 C the orientation of the CA-CA virtual bonds.
2149 C
2150       implicit real*8 (a-h,o-z)
2151       include 'DIMENSIONS'
2152       include 'COMMON.CONTROL'
2153       include 'COMMON.IOUNITS'
2154       include 'COMMON.GEO'
2155       include 'COMMON.VAR'
2156       include 'COMMON.LOCAL'
2157       include 'COMMON.CHAIN'
2158       include 'COMMON.DERIV'
2159       include 'COMMON.INTERACT'
2160       include 'COMMON.CONTACTS'
2161       include 'COMMON.TORSION'
2162       include 'COMMON.VECTORS'
2163       include 'COMMON.FFIELD'
2164       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2165      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2166       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2167      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2168       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2169 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2170 #ifdef MOMENT
2171       double precision scal_el /1.0d0/
2172 #else
2173       double precision scal_el /0.5d0/
2174 #endif
2175 C 12/13/98
2176 C 13-go grudnia roku pamietnego...
2177       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2178      &                   0.0d0,1.0d0,0.0d0,
2179      &                   0.0d0,0.0d0,1.0d0/
2180 cd      write(iout,*) 'In EELEC'
2181 cd      do i=1,nloctyp
2182 cd        write(iout,*) 'Type',i
2183 cd        write(iout,*) 'B1',B1(:,i)
2184 cd        write(iout,*) 'B2',B2(:,i)
2185 cd        write(iout,*) 'CC',CC(:,:,i)
2186 cd        write(iout,*) 'DD',DD(:,:,i)
2187 cd        write(iout,*) 'EE',EE(:,:,i)
2188 cd      enddo
2189 cd      call check_vecgrad
2190 cd      stop
2191       if (icheckgrad.eq.1) then
2192         do i=1,nres-1
2193           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2194           do k=1,3
2195             dc_norm(k,i)=dc(k,i)*fac
2196           enddo
2197 c          write (iout,*) 'i',i,' fac',fac
2198         enddo
2199       endif
2200       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2201      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2202      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2203 c        call vec_and_deriv
2204         call set_matrices
2205       endif
2206 cd      do i=1,nres-1
2207 cd        write (iout,*) 'i=',i
2208 cd        do k=1,3
2209 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2210 cd        enddo
2211 cd        do k=1,3
2212 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2213 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2214 cd        enddo
2215 cd      enddo
2216       num_conti_hb=0
2217       ees=0.0D0
2218       evdw1=0.0D0
2219       eel_loc=0.0d0
2220       eello_turn3=0.0d0
2221       eello_turn4=0.0d0
2222       ind=0
2223       do i=1,nres
2224         num_cont_hb(i)=0
2225       enddo
2226 cd      print '(a)','Enter EELEC'
2227 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2228       do i=1,nres
2229         gel_loc_loc(i)=0.0d0
2230         gcorr_loc(i)=0.0d0
2231       enddo
2232       do i=iatel_s,iatel_e
2233         dxi=dc(1,i)
2234         dyi=dc(2,i)
2235         dzi=dc(3,i)
2236         dx_normi=dc_norm(1,i)
2237         dy_normi=dc_norm(2,i)
2238         dz_normi=dc_norm(3,i)
2239         xmedi=c(1,i)+0.5d0*dxi
2240         ymedi=c(2,i)+0.5d0*dyi
2241         zmedi=c(3,i)+0.5d0*dzi
2242         num_conti=0
2243 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2244         do j=ielstart(i),ielend(i)
2245           ind=ind+1
2246           iteli=itel(i)
2247           itelj=itel(j)
2248           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2249           aaa=app(iteli,itelj)
2250           bbb=bpp(iteli,itelj)
2251           ael6i=ael6(iteli,itelj)
2252           ael3i=ael3(iteli,itelj)
2253 C Diagnostics only!!!
2254 c         aaa=0.0D0
2255 c         bbb=0.0D0
2256 c         ael6i=0.0D0
2257 c         ael3i=0.0D0
2258 C End diagnostics
2259           dxj=dc(1,j)
2260           dyj=dc(2,j)
2261           dzj=dc(3,j)
2262           dx_normj=dc_norm(1,j)
2263           dy_normj=dc_norm(2,j)
2264           dz_normj=dc_norm(3,j)
2265           xj=c(1,j)+0.5D0*dxj-xmedi
2266           yj=c(2,j)+0.5D0*dyj-ymedi
2267           zj=c(3,j)+0.5D0*dzj-zmedi
2268           rij=xj*xj+yj*yj+zj*zj
2269           rrmij=1.0D0/rij
2270           rij=dsqrt(rij)
2271           rmij=1.0D0/rij
2272           r3ij=rrmij*rmij
2273           r6ij=r3ij*r3ij
2274           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2275           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2276           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2277           fac=cosa-3.0D0*cosb*cosg
2278           ev1=aaa*r6ij*r6ij
2279 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2280           if (j.eq.i+2) ev1=scal_el*ev1
2281           ev2=bbb*r6ij
2282           fac3=ael6i*r6ij
2283           fac4=ael3i*r3ij
2284           evdwij=ev1+ev2
2285           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2286           el2=fac4*fac
2287           eesij=el1+el2
2288 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2289           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2290           ees=ees+eesij
2291           evdw1=evdw1+evdwij
2292 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2293 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2294 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2295 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2296
2297           if (energy_dec) then
2298               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2299               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2300           endif
2301
2302 C
2303 C Calculate contributions to the Cartesian gradient.
2304 C
2305 #ifdef SPLITELE
2306           facvdw=-6*rrmij*(ev1+evdwij)
2307           facel=-3*rrmij*(el1+eesij)
2308           fac1=fac
2309           erij(1)=xj*rmij
2310           erij(2)=yj*rmij
2311           erij(3)=zj*rmij
2312 *
2313 * Radial derivatives. First process both termini of the fragment (i,j)
2314 *
2315           ggg(1)=facel*xj
2316           ggg(2)=facel*yj
2317           ggg(3)=facel*zj
2318           do k=1,3
2319             ghalf=0.5D0*ggg(k)
2320             gelc(k,i)=gelc(k,i)+ghalf
2321             gelc(k,j)=gelc(k,j)+ghalf
2322           enddo
2323 *
2324 * Loop over residues i+1 thru j-1.
2325 *
2326 caug8          do k=i+1,j-1
2327 caug8            do l=1,3
2328 caug8              gelc(l,k)=gelc(l,k)+ggg(l)
2329 caug8            enddo
2330 caug8          enddo
2331           ggg(1)=facvdw*xj
2332           ggg(2)=facvdw*yj
2333           ggg(3)=facvdw*zj
2334           do k=1,3
2335             ghalf=0.5D0*ggg(k)
2336             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2337             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2338           enddo
2339 *
2340 * Loop over residues i+1 thru j-1.
2341 *
2342 cAug8          do k=i+1,j-1
2343 cAug8            do l=1,3
2344 cAug8              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2345 cAug8            enddo
2346 cAug8          enddo
2347 #else
2348           facvdw=ev1+evdwij
2349           facel=el1+eesij
2350           fac1=fac
2351           fac=-3*rrmij*(facvdw+facvdw+facel)
2352           erij(1)=xj*rmij
2353           erij(2)=yj*rmij
2354           erij(3)=zj*rmij
2355 *
2356 * Radial derivatives. First process both termini of the fragment (i,j)
2357 *
2358           ggg(1)=fac*xj
2359           ggg(2)=fac*yj
2360           ggg(3)=fac*zj
2361           do k=1,3
2362             ghalf=0.5D0*ggg(k)
2363             gelc(k,i)=gelc(k,i)+ghalf
2364             gelc(k,j)=gelc(k,j)+ghalf
2365           enddo
2366 *
2367 * Loop over residues i+1 thru j-1.
2368 *
2369 cAug8          do k=i+1,j-1
2370 cAug8            do l=1,3
2371 cAug8              gelc(l,k)=gelc(l,k)+ggg(l)
2372 cAug8            enddo
2373 cAug8          enddo
2374 #endif
2375 *
2376 * Angular part
2377 *
2378           ecosa=2.0D0*fac3*fac1+fac4
2379           fac4=-3.0D0*fac4
2380           fac3=-6.0D0*fac3
2381           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2382           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2383           do k=1,3
2384             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2385             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2386           enddo
2387 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2388 cd   &          (dcosg(k),k=1,3)
2389           do k=1,3
2390             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2391           enddo
2392           do k=1,3
2393             ghalf=0.5D0*ggg(k)
2394             gelc(k,i)=gelc(k,i)+ghalf
2395      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2396      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2397             gelc(k,j)=gelc(k,j)+ghalf
2398      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2399      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2400           enddo
2401 cAug8          do k=i+1,j-1
2402 cAug8            do l=1,3
2403 cAug8              gelc(l,k)=gelc(l,k)+ggg(l)
2404 cAug8            enddo
2405 cAug8          enddo
2406
2407         enddo ! j
2408         num_cont_hb(i)=num_conti
2409       enddo   ! i
2410 cd      write (iout,*) "Number of loop steps in EELEC:",ind
2411 cd      do i=1,nres
2412 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2413 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2414 cd      enddo
2415 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2416 ccc      eel_loc=eel_loc+eello_turn3
2417       return
2418       end
2419 C-----------------------------------------------------------------------------
2420       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2421 C Third- and fourth-order contributions from turns
2422       implicit real*8 (a-h,o-z)
2423       include 'DIMENSIONS'
2424       include 'COMMON.IOUNITS'
2425       include 'COMMON.GEO'
2426       include 'COMMON.VAR'
2427       include 'COMMON.LOCAL'
2428       include 'COMMON.CHAIN'
2429       include 'COMMON.DERIV'
2430       include 'COMMON.INTERACT'
2431       include 'COMMON.CONTACTS'
2432       include 'COMMON.TORSION'
2433       include 'COMMON.VECTORS'
2434       include 'COMMON.FFIELD'
2435       include 'COMMON.CONTROL'
2436       dimension ggg(3)
2437       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2438      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2439      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2440       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2441      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
2442       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2443       if (j.eq.i+2) then
2444 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2445 C
2446 C               Third-order contributions
2447 C
2448 C                 (i+2)o----(i+3)
2449 C                      | |
2450 C                      | |
2451 C                 (i+1)o----i
2452 C
2453 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2454 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2455         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2456         call transpose2(auxmat(1,1),auxmat1(1,1))
2457         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2458         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2459         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2460      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
2461 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2462 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2463 cd     &    ' eello_turn3_num',4*eello_turn3_num
2464 C Derivatives in gamma(i)
2465         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2466         call transpose2(auxmat2(1,1),auxmat3(1,1))
2467         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
2468         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2469 C Derivatives in gamma(i+1)
2470         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2471         call transpose2(auxmat2(1,1),auxmat3(1,1))
2472         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
2473         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2474      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2475 C Cartesian derivatives
2476         do l=1,3
2477           a_temp(1,1)=aggi(l,1)
2478           a_temp(1,2)=aggi(l,2)
2479           a_temp(2,1)=aggi(l,3)
2480           a_temp(2,2)=aggi(l,4)
2481           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2482           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2483      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2484           a_temp(1,1)=aggi1(l,1)
2485           a_temp(1,2)=aggi1(l,2)
2486           a_temp(2,1)=aggi1(l,3)
2487           a_temp(2,2)=aggi1(l,4)
2488           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2489           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2490      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2491           a_temp(1,1)=aggj(l,1)
2492           a_temp(1,2)=aggj(l,2)
2493           a_temp(2,1)=aggj(l,3)
2494           a_temp(2,2)=aggj(l,4)
2495           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2496           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2497      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2498           a_temp(1,1)=aggj1(l,1)
2499           a_temp(1,2)=aggj1(l,2)
2500           a_temp(2,1)=aggj1(l,3)
2501           a_temp(2,2)=aggj1(l,4)
2502           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2503           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2504      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2505         enddo
2506       else if (j.eq.i+3) then
2507 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2508 C
2509 C               Fourth-order contributions
2510 C
2511 C                 (i+3)o----(i+4)
2512 C                     /  |
2513 C               (i+2)o   |
2514 C                     \  |
2515 C                 (i+1)o----i
2516 C
2517 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2518 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2519         iti1=itortyp(itype(i+1))
2520         iti2=itortyp(itype(i+2))
2521         iti3=itortyp(itype(i+3))
2522         call transpose2(EUg(1,1,i+1),e1t(1,1))
2523         call transpose2(Eug(1,1,i+2),e2t(1,1))
2524         call transpose2(Eug(1,1,i+3),e3t(1,1))
2525         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2526         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2527         s1=scalar2(b1(1,iti2),auxvec(1))
2528         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2529         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2530         s2=scalar2(b1(1,iti1),auxvec(1))
2531         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2532         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2533         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2534         eello_turn4=eello_turn4-(s1+s2+s3)
2535         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2536      &      'eturn4',i,j,-(s1+s2+s3)
2537 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2538 cd     &    ' eello_turn4_num',8*eello_turn4_num
2539 C Derivatives in gamma(i)
2540         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2541         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2542         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2543         s1=scalar2(b1(1,iti2),auxvec(1))
2544         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2545         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2546         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2547 C Derivatives in gamma(i+1)
2548         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2549         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2550         s2=scalar2(b1(1,iti1),auxvec(1))
2551         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2552         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2553         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2554         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2555 C Derivatives in gamma(i+2)
2556         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2557         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2558         s1=scalar2(b1(1,iti2),auxvec(1))
2559         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2560         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2561         s2=scalar2(b1(1,iti1),auxvec(1))
2562         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
2563         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
2564         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2565         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2566 C Cartesian derivatives
2567 C Derivatives of this turn contributions in DC(i+2)
2568         if (j.lt.nres-1) then
2569           do l=1,3
2570             a_temp(1,1)=agg(l,1)
2571             a_temp(1,2)=agg(l,2)
2572             a_temp(2,1)=agg(l,3)
2573             a_temp(2,2)=agg(l,4)
2574             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2575             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2576             s1=scalar2(b1(1,iti2),auxvec(1))
2577             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2578             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2579             s2=scalar2(b1(1,iti1),auxvec(1))
2580             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2581             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2582             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2583             ggg(l)=-(s1+s2+s3)
2584             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2585           enddo
2586         endif
2587 C Remaining derivatives of this turn contribution
2588         do l=1,3
2589           a_temp(1,1)=aggi(l,1)
2590           a_temp(1,2)=aggi(l,2)
2591           a_temp(2,1)=aggi(l,3)
2592           a_temp(2,2)=aggi(l,4)
2593           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2594           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2595           s1=scalar2(b1(1,iti2),auxvec(1))
2596           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2597           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2598           s2=scalar2(b1(1,iti1),auxvec(1))
2599           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2600           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2601           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2602           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2603           a_temp(1,1)=aggi1(l,1)
2604           a_temp(1,2)=aggi1(l,2)
2605           a_temp(2,1)=aggi1(l,3)
2606           a_temp(2,2)=aggi1(l,4)
2607           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2608           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2609           s1=scalar2(b1(1,iti2),auxvec(1))
2610           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2611           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2612           s2=scalar2(b1(1,iti1),auxvec(1))
2613           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2614           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2615           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2616           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2617           a_temp(1,1)=aggj(l,1)
2618           a_temp(1,2)=aggj(l,2)
2619           a_temp(2,1)=aggj(l,3)
2620           a_temp(2,2)=aggj(l,4)
2621           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2622           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2623           s1=scalar2(b1(1,iti2),auxvec(1))
2624           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2625           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2626           s2=scalar2(b1(1,iti1),auxvec(1))
2627           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2628           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2629           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2630           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2631           a_temp(1,1)=aggj1(l,1)
2632           a_temp(1,2)=aggj1(l,2)
2633           a_temp(2,1)=aggj1(l,3)
2634           a_temp(2,2)=aggj1(l,4)
2635           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2636           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2637           s1=scalar2(b1(1,iti2),auxvec(1))
2638           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2639           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2640           s2=scalar2(b1(1,iti1),auxvec(1))
2641           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2642           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2643           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2644           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2645         enddo
2646       endif
2647       return
2648       end
2649 C-----------------------------------------------------------------------------
2650       subroutine vecpr(u,v,w)
2651       implicit real*8(a-h,o-z)
2652       dimension u(3),v(3),w(3)
2653       w(1)=u(2)*v(3)-u(3)*v(2)
2654       w(2)=-u(1)*v(3)+u(3)*v(1)
2655       w(3)=u(1)*v(2)-u(2)*v(1)
2656       return
2657       end
2658 C-----------------------------------------------------------------------------
2659       subroutine unormderiv(u,ugrad,unorm,ungrad)
2660 C This subroutine computes the derivatives of a normalized vector u, given
2661 C the derivatives computed without normalization conditions, ugrad. Returns
2662 C ungrad.
2663       implicit none
2664       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
2665       double precision vec(3)
2666       double precision scalar
2667       integer i,j
2668 c      write (2,*) 'ugrad',ugrad
2669 c      write (2,*) 'u',u
2670       do i=1,3
2671         vec(i)=scalar(ugrad(1,i),u(1))
2672       enddo
2673 c      write (2,*) 'vec',vec
2674       do i=1,3
2675         do j=1,3
2676           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
2677         enddo
2678       enddo
2679 c      write (2,*) 'ungrad',ungrad
2680       return
2681       end
2682 C-----------------------------------------------------------------------------
2683       subroutine escp_soft_sphere(evdw2,evdw2_14)
2684 C
2685 C This subroutine calculates the excluded-volume interaction energy between
2686 C peptide-group centers and side chains and its gradient in virtual-bond and
2687 C side-chain vectors.
2688 C
2689       implicit real*8 (a-h,o-z)
2690       include 'DIMENSIONS'
2691       include 'COMMON.GEO'
2692       include 'COMMON.VAR'
2693       include 'COMMON.LOCAL'
2694       include 'COMMON.CHAIN'
2695       include 'COMMON.DERIV'
2696       include 'COMMON.INTERACT'
2697       include 'COMMON.FFIELD'
2698       include 'COMMON.IOUNITS'
2699       include 'COMMON.CONTROL'
2700       dimension ggg(3)
2701       evdw2=0.0D0
2702       evdw2_14=0.0d0
2703       r0_scp=4.5d0
2704 cd    print '(a)','Enter ESCP'
2705 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
2706       do i=iatscp_s,iatscp_e
2707         iteli=itel(i)
2708         xi=0.5D0*(c(1,i)+c(1,i+1))
2709         yi=0.5D0*(c(2,i)+c(2,i+1))
2710         zi=0.5D0*(c(3,i)+c(3,i+1))
2711
2712         do iint=1,nscp_gr(i)
2713
2714         do j=iscpstart(i,iint),iscpend(i,iint)
2715           itypj=itype(j)
2716 C Uncomment following three lines for SC-p interactions
2717 c         xj=c(1,nres+j)-xi
2718 c         yj=c(2,nres+j)-yi
2719 c         zj=c(3,nres+j)-zi
2720 C Uncomment following three lines for Ca-p interactions
2721           xj=c(1,j)-xi
2722           yj=c(2,j)-yi
2723           zj=c(3,j)-zi
2724           rij=xj*xj+yj*yj+zj*zj
2725           r0ij=r0_scp
2726           r0ijsq=r0ij*r0ij
2727           if (rij.lt.r0ijsq) then
2728             evdwij=0.25d0*(rij-r0ijsq)**2
2729             fac=rij-r0ijsq
2730           else
2731             evdwij=0.0d0
2732             fac=0.0d0
2733           endif
2734           evdw2=evdw2+evdwij
2735 C
2736 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2737 C
2738           ggg(1)=xj*fac
2739           ggg(2)=yj*fac
2740           ggg(3)=zj*fac
2741           if (j.lt.i) then
2742 cd          write (iout,*) 'j<i'
2743 C Uncomment following three lines for SC-p interactions
2744 c           do k=1,3
2745 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2746 c           enddo
2747           else
2748 cd          write (iout,*) 'j>i'
2749             do k=1,3
2750               ggg(k)=-ggg(k)
2751 C Uncomment following line for SC-p interactions
2752 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2753             enddo
2754           endif
2755           do k=1,3
2756             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2757           enddo
2758           kstart=min0(i+1,j)
2759           kend=max0(i-1,j-1)
2760 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2761 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2762           do k=kstart,kend
2763             do l=1,3
2764               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2765             enddo
2766           enddo
2767         enddo
2768
2769         enddo ! iint
2770       enddo ! i
2771       return
2772       end
2773 C-----------------------------------------------------------------------------
2774       subroutine escp(evdw2,evdw2_14)
2775 C
2776 C This subroutine calculates the excluded-volume interaction energy between
2777 C peptide-group centers and side chains and its gradient in virtual-bond and
2778 C side-chain vectors.
2779 C
2780       implicit real*8 (a-h,o-z)
2781       include 'DIMENSIONS'
2782       include 'COMMON.GEO'
2783       include 'COMMON.VAR'
2784       include 'COMMON.LOCAL'
2785       include 'COMMON.CHAIN'
2786       include 'COMMON.DERIV'
2787       include 'COMMON.INTERACT'
2788       include 'COMMON.FFIELD'
2789       include 'COMMON.IOUNITS'
2790       include 'COMMON.CONTROL'
2791       dimension ggg(3)
2792       evdw2=0.0D0
2793       evdw2_14=0.0d0
2794 cd    print '(a)','Enter ESCP'
2795 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
2796       do i=iatscp_s,iatscp_e
2797         iteli=itel(i)
2798         xi=0.5D0*(c(1,i)+c(1,i+1))
2799         yi=0.5D0*(c(2,i)+c(2,i+1))
2800         zi=0.5D0*(c(3,i)+c(3,i+1))
2801
2802         do iint=1,nscp_gr(i)
2803
2804         do j=iscpstart(i,iint),iscpend(i,iint)
2805           itypj=itype(j)
2806 C Uncomment following three lines for SC-p interactions
2807 c         xj=c(1,nres+j)-xi
2808 c         yj=c(2,nres+j)-yi
2809 c         zj=c(3,nres+j)-zi
2810 C Uncomment following three lines for Ca-p interactions
2811           xj=c(1,j)-xi
2812           yj=c(2,j)-yi
2813           zj=c(3,j)-zi
2814           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2815           fac=rrij**expon2
2816           e1=fac*fac*aad(itypj,iteli)
2817           e2=fac*bad(itypj,iteli)
2818           if (iabs(j-i) .le. 2) then
2819             e1=scal14*e1
2820             e2=scal14*e2
2821             evdw2_14=evdw2_14+e1+e2
2822           endif
2823           evdwij=e1+e2
2824           evdw2=evdw2+evdwij
2825           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2826      &        'evdw2',i,j,evdwij
2827 C
2828 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
2829 C
2830           fac=-(evdwij+e1)*rrij
2831           ggg(1)=xj*fac
2832           ggg(2)=yj*fac
2833           ggg(3)=zj*fac
2834           if (j.lt.i) then
2835 cd          write (iout,*) 'j<i'
2836 C Uncomment following three lines for SC-p interactions
2837 c           do k=1,3
2838 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
2839 c           enddo
2840           else
2841 cd          write (iout,*) 'j>i'
2842             do k=1,3
2843               ggg(k)=-ggg(k)
2844 C Uncomment following line for SC-p interactions
2845 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
2846             enddo
2847           endif
2848           do k=1,3
2849             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
2850           enddo
2851           kstart=min0(i+1,j)
2852           kend=max0(i-1,j-1)
2853 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
2854 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
2855           do k=kstart,kend
2856             do l=1,3
2857               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
2858             enddo
2859           enddo
2860         enddo
2861
2862         enddo ! iint
2863       enddo ! i
2864       do i=1,nct
2865         do j=1,3
2866           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
2867           gradx_scp(j,i)=expon*gradx_scp(j,i)
2868         enddo
2869       enddo
2870 C******************************************************************************
2871 C
2872 C                              N O T E !!!
2873 C
2874 C To save time the factor EXPON has been extracted from ALL components
2875 C of GVDWC and GRADX. Remember to multiply them by this factor before further
2876 C use!
2877 C
2878 C******************************************************************************
2879       return
2880       end
2881 C--------------------------------------------------------------------------
2882       subroutine edis(ehpb)
2883 C
2884 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
2885 C
2886       implicit real*8 (a-h,o-z)
2887       include 'DIMENSIONS'
2888       include 'COMMON.SBRIDGE'
2889       include 'COMMON.CHAIN'
2890       include 'COMMON.DERIV'
2891       include 'COMMON.VAR'
2892       include 'COMMON.INTERACT'
2893       dimension ggg(3)
2894       ehpb=0.0D0
2895 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
2896 cd    print *,'link_start=',link_start,' link_end=',link_end
2897       if (link_end.eq.0) return
2898       do i=link_start,link_end
2899 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
2900 C CA-CA distance used in regularization of structure.
2901         ii=ihpb(i)
2902         jj=jhpb(i)
2903 C iii and jjj point to the residues for which the distance is assigned.
2904         if (ii.gt.nres) then
2905           iii=ii-nres
2906           jjj=jj-nres
2907         else
2908           iii=ii
2909           jjj=jj
2910         endif
2911 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
2912 C    distance and angle dependent SS bond potential.
2913         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
2914           call ssbond_ene(iii,jjj,eij)
2915           ehpb=ehpb+2*eij
2916         else
2917 C Calculate the distance between the two points and its difference from the
2918 C target distance.
2919         dd=dist(ii,jj)
2920         rdis=dd-dhpb(i)
2921 C Get the force constant corresponding to this distance.
2922         waga=forcon(i)
2923 C Calculate the contribution to energy.
2924         ehpb=ehpb+waga*rdis*rdis
2925 C
2926 C Evaluate gradient.
2927 C
2928         fac=waga*rdis/dd
2929 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
2930 cd   &   ' waga=',waga,' fac=',fac
2931         do j=1,3
2932           ggg(j)=fac*(c(j,jj)-c(j,ii))
2933         enddo
2934 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
2935 C If this is a SC-SC distance, we need to calculate the contributions to the
2936 C Cartesian gradient in the SC vectors (ghpbx).
2937         if (iii.lt.ii) then
2938           do j=1,3
2939             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
2940             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
2941           enddo
2942         endif
2943         do j=iii,jjj-1
2944           do k=1,3
2945             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
2946           enddo
2947         enddo
2948         endif
2949       enddo
2950       ehpb=0.5D0*ehpb
2951       return
2952       end
2953 C--------------------------------------------------------------------------
2954       subroutine ssbond_ene(i,j,eij)
2955 C
2956 C Calculate the distance and angle dependent SS-bond potential energy
2957 C using a free-energy function derived based on RHF/6-31G** ab initio
2958 C calculations of diethyl disulfide.
2959 C
2960 C A. Liwo and U. Kozlowska, 11/24/03
2961 C
2962       implicit real*8 (a-h,o-z)
2963       include 'DIMENSIONS'
2964       include 'COMMON.SBRIDGE'
2965       include 'COMMON.CHAIN'
2966       include 'COMMON.DERIV'
2967       include 'COMMON.LOCAL'
2968       include 'COMMON.INTERACT'
2969       include 'COMMON.VAR'
2970       include 'COMMON.IOUNITS'
2971       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
2972       itypi=itype(i)
2973       xi=c(1,nres+i)
2974       yi=c(2,nres+i)
2975       zi=c(3,nres+i)
2976       dxi=dc_norm(1,nres+i)
2977       dyi=dc_norm(2,nres+i)
2978       dzi=dc_norm(3,nres+i)
2979       dsci_inv=dsc_inv(itypi)
2980       itypj=itype(j)
2981       dscj_inv=dsc_inv(itypj)
2982       xj=c(1,nres+j)-xi
2983       yj=c(2,nres+j)-yi
2984       zj=c(3,nres+j)-zi
2985       dxj=dc_norm(1,nres+j)
2986       dyj=dc_norm(2,nres+j)
2987       dzj=dc_norm(3,nres+j)
2988       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2989       rij=dsqrt(rrij)
2990       erij(1)=xj*rij
2991       erij(2)=yj*rij
2992       erij(3)=zj*rij
2993       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2994       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2995       om12=dxi*dxj+dyi*dyj+dzi*dzj
2996       do k=1,3
2997         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2998         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2999       enddo
3000       rij=1.0d0/rij
3001       deltad=rij-d0cm
3002       deltat1=1.0d0-om1
3003       deltat2=1.0d0+om2
3004       deltat12=om2-om1+2.0d0
3005       cosphi=om12-om1*om2
3006       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3007      &  +akct*deltad*deltat12
3008      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3009 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3010 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3011 c     &  " deltat12",deltat12," eij",eij
3012       ed=2*akcm*deltad+akct*deltat12
3013       pom1=akct*deltad
3014       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3015       eom1=-2*akth*deltat1-pom1-om2*pom2
3016       eom2= 2*akth*deltat2+pom1-om1*pom2
3017       eom12=pom2
3018       do k=1,3
3019         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3020       enddo
3021       do k=1,3
3022         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3023      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3024         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3025      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3026       enddo
3027 C
3028 C Calculate the components of the gradient in DC and X
3029 C
3030       do k=i,j-1
3031         do l=1,3
3032           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3033         enddo
3034       enddo
3035       return
3036       end
3037 C--------------------------------------------------------------------------
3038       subroutine ebond(estr)
3039 c
3040 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3041 c
3042       implicit real*8 (a-h,o-z)
3043       include 'DIMENSIONS'
3044       include 'COMMON.LOCAL'
3045       include 'COMMON.GEO'
3046       include 'COMMON.INTERACT'
3047       include 'COMMON.DERIV'
3048       include 'COMMON.VAR'
3049       include 'COMMON.CHAIN'
3050       include 'COMMON.IOUNITS'
3051       include 'COMMON.NAMES'
3052       include 'COMMON.FFIELD'
3053       include 'COMMON.CONTROL'
3054       include 'COMMON.SETUP'
3055       double precision u(3),ud(3)
3056       estr=0.0d0
3057       do i=ibondp_start,ibondp_end
3058         diff = vbld(i)-vbldp0
3059 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3060         estr=estr+diff*diff
3061         do j=1,3
3062           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3063         enddo
3064 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
3065       enddo
3066       estr=0.5d0*AKP*estr
3067 c
3068 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3069 c
3070       do i=ibond_start,ibond_end
3071         iti=itype(i)
3072         if (iti.ne.10) then
3073           nbi=nbondterm(iti)
3074           if (nbi.eq.1) then
3075             diff=vbld(i+nres)-vbldsc0(1,iti)
3076 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3077 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3078             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3079             do j=1,3
3080               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3081             enddo
3082           else
3083             do j=1,nbi
3084               diff=vbld(i+nres)-vbldsc0(j,iti)
3085               ud(j)=aksc(j,iti)*diff
3086               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3087             enddo
3088             uprod=u(1)
3089             do j=2,nbi
3090               uprod=uprod*u(j)
3091             enddo
3092             usum=0.0d0
3093             usumsqder=0.0d0
3094             do j=1,nbi
3095               uprod1=1.0d0
3096               uprod2=1.0d0
3097               do k=1,nbi
3098                 if (k.ne.j) then
3099                   uprod1=uprod1*u(k)
3100                   uprod2=uprod2*u(k)*u(k)
3101                 endif
3102               enddo
3103               usum=usum+uprod1
3104               usumsqder=usumsqder+ud(j)*uprod2
3105             enddo
3106             estr=estr+uprod/usum
3107             do j=1,3
3108              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3109             enddo
3110           endif
3111         endif
3112       enddo
3113       return
3114       end
3115 #ifdef CRYST_THETA
3116 C--------------------------------------------------------------------------
3117       subroutine ebend(etheta)
3118 C
3119 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3120 C angles gamma and its derivatives in consecutive thetas and gammas.
3121 C
3122       implicit real*8 (a-h,o-z)
3123       include 'DIMENSIONS'
3124       include 'COMMON.LOCAL'
3125       include 'COMMON.GEO'
3126       include 'COMMON.INTERACT'
3127       include 'COMMON.DERIV'
3128       include 'COMMON.VAR'
3129       include 'COMMON.CHAIN'
3130       include 'COMMON.IOUNITS'
3131       include 'COMMON.NAMES'
3132       include 'COMMON.FFIELD'
3133       include 'COMMON.CONTROL'
3134       common /calcthet/ term1,term2,termm,diffak,ratak,
3135      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3136      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3137       double precision y(2),z(2)
3138       delta=0.02d0*pi
3139 c      time11=dexp(-2*time)
3140 c      time12=1.0d0
3141       etheta=0.0D0
3142 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3143       do i=ithet_start,ithet_end
3144 C Zero the energy function and its derivative at 0 or pi.
3145         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3146         it=itype(i-1)
3147         if (i.gt.3) then
3148 #ifdef OSF
3149           phii=phi(i)
3150           if (phii.ne.phii) phii=150.0
3151 #else
3152           phii=phi(i)
3153 #endif
3154           y(1)=dcos(phii)
3155           y(2)=dsin(phii)
3156         else
3157           y(1)=0.0D0
3158           y(2)=0.0D0
3159         endif
3160         if (i.lt.nres) then
3161 #ifdef OSF
3162           phii1=phi(i+1)
3163           if (phii1.ne.phii1) phii1=150.0
3164           phii1=pinorm(phii1)
3165           z(1)=cos(phii1)
3166 #else
3167           phii1=phi(i+1)
3168           z(1)=dcos(phii1)
3169 #endif
3170           z(2)=dsin(phii1)
3171         else
3172           z(1)=0.0D0
3173           z(2)=0.0D0
3174         endif
3175 C Calculate the "mean" value of theta from the part of the distribution
3176 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3177 C In following comments this theta will be referred to as t_c.
3178         thet_pred_mean=0.0d0
3179         do k=1,2
3180           athetk=athet(k,it)
3181           bthetk=bthet(k,it)
3182           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3183         enddo
3184         dthett=thet_pred_mean*ssd
3185         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3186 C Derivatives of the "mean" values in gamma1 and gamma2.
3187         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3188         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3189         if (theta(i).gt.pi-delta) then
3190           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3191      &         E_tc0)
3192           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3193           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3194           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3195      &        E_theta)
3196           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3197      &        E_tc)
3198         else if (theta(i).lt.delta) then
3199           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3200           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3201           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3202      &        E_theta)
3203           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3204           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3205      &        E_tc)
3206         else
3207           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3208      &        E_theta,E_tc)
3209         endif
3210         etheta=etheta+ethetai
3211         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
3212      &      'ebend',i,ethetai
3213         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3214         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3215         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3216       enddo
3217 C Ufff.... We've done all this!!!
3218       return
3219       end
3220 C---------------------------------------------------------------------------
3221       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3222      &     E_tc)
3223       implicit real*8 (a-h,o-z)
3224       include 'DIMENSIONS'
3225       include 'COMMON.LOCAL'
3226       include 'COMMON.IOUNITS'
3227       common /calcthet/ term1,term2,termm,diffak,ratak,
3228      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3229      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3230 C Calculate the contributions to both Gaussian lobes.
3231 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
3232 C The "polynomial part" of the "standard deviation" of this part of
3233 C the distribution.
3234         sig=polthet(3,it)
3235         do j=2,0,-1
3236           sig=sig*thet_pred_mean+polthet(j,it)
3237         enddo
3238 C Derivative of the "interior part" of the "standard deviation of the"
3239 C gamma-dependent Gaussian lobe in t_c.
3240         sigtc=3*polthet(3,it)
3241         do j=2,1,-1
3242           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
3243         enddo
3244         sigtc=sig*sigtc
3245 C Set the parameters of both Gaussian lobes of the distribution.
3246 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
3247         fac=sig*sig+sigc0(it)
3248         sigcsq=fac+fac
3249         sigc=1.0D0/sigcsq
3250 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
3251         sigsqtc=-4.0D0*sigcsq*sigtc
3252 c       print *,i,sig,sigtc,sigsqtc
3253 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
3254         sigtc=-sigtc/(fac*fac)
3255 C Following variable is sigma(t_c)**(-2)
3256         sigcsq=sigcsq*sigcsq
3257         sig0i=sig0(it)
3258         sig0inv=1.0D0/sig0i**2
3259         delthec=thetai-thet_pred_mean
3260         delthe0=thetai-theta0i
3261         term1=-0.5D0*sigcsq*delthec*delthec
3262         term2=-0.5D0*sig0inv*delthe0*delthe0
3263 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
3264 C NaNs in taking the logarithm. We extract the largest exponent which is added
3265 C to the energy (this being the log of the distribution) at the end of energy
3266 C term evaluation for this virtual-bond angle.
3267         if (term1.gt.term2) then
3268           termm=term1
3269           term2=dexp(term2-termm)
3270           term1=1.0d0
3271         else
3272           termm=term2
3273           term1=dexp(term1-termm)
3274           term2=1.0d0
3275         endif
3276 C The ratio between the gamma-independent and gamma-dependent lobes of
3277 C the distribution is a Gaussian function of thet_pred_mean too.
3278         diffak=gthet(2,it)-thet_pred_mean
3279         ratak=diffak/gthet(3,it)**2
3280         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
3281 C Let's differentiate it in thet_pred_mean NOW.
3282         aktc=ak*ratak
3283 C Now put together the distribution terms to make complete distribution.
3284         termexp=term1+ak*term2
3285         termpre=sigc+ak*sig0i
3286 C Contribution of the bending energy from this theta is just the -log of
3287 C the sum of the contributions from the two lobes and the pre-exponential
3288 C factor. Simple enough, isn't it?
3289         ethetai=(-dlog(termexp)-termm+dlog(termpre))
3290 C NOW the derivatives!!!
3291 C 6/6/97 Take into account the deformation.
3292         E_theta=(delthec*sigcsq*term1
3293      &       +ak*delthe0*sig0inv*term2)/termexp
3294         E_tc=((sigtc+aktc*sig0i)/termpre
3295      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
3296      &       aktc*term2)/termexp)
3297       return
3298       end
3299 c-----------------------------------------------------------------------------
3300       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
3301       implicit real*8 (a-h,o-z)
3302       include 'DIMENSIONS'
3303       include 'COMMON.LOCAL'
3304       include 'COMMON.IOUNITS'
3305       common /calcthet/ term1,term2,termm,diffak,ratak,
3306      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3307      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3308       delthec=thetai-thet_pred_mean
3309       delthe0=thetai-theta0i
3310 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
3311       t3 = thetai-thet_pred_mean
3312       t6 = t3**2
3313       t9 = term1
3314       t12 = t3*sigcsq
3315       t14 = t12+t6*sigsqtc
3316       t16 = 1.0d0
3317       t21 = thetai-theta0i
3318       t23 = t21**2
3319       t26 = term2
3320       t27 = t21*t26
3321       t32 = termexp
3322       t40 = t32**2
3323       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
3324      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
3325      & *(-t12*t9-ak*sig0inv*t27)
3326       return
3327       end
3328 #else
3329 C--------------------------------------------------------------------------
3330       subroutine ebend(etheta)
3331 C
3332 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3333 C angles gamma and its derivatives in consecutive thetas and gammas.
3334 C ab initio-derived potentials from
3335 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
3336 C
3337       implicit real*8 (a-h,o-z)
3338       include 'DIMENSIONS'
3339       include 'COMMON.LOCAL'
3340       include 'COMMON.GEO'
3341       include 'COMMON.INTERACT'
3342       include 'COMMON.DERIV'
3343       include 'COMMON.VAR'
3344       include 'COMMON.CHAIN'
3345       include 'COMMON.IOUNITS'
3346       include 'COMMON.NAMES'
3347       include 'COMMON.FFIELD'
3348       include 'COMMON.CONTROL'
3349       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
3350      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
3351      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
3352      & sinph1ph2(maxdouble,maxdouble)
3353       logical lprn /.false./, lprn1 /.false./
3354       etheta=0.0D0
3355       do i=ithet_start,ithet_end
3356         dethetai=0.0d0
3357         dephii=0.0d0
3358         dephii1=0.0d0
3359         theti2=0.5d0*theta(i)
3360         ityp2=ithetyp(itype(i-1))
3361         do k=1,nntheterm
3362           coskt(k)=dcos(k*theti2)
3363           sinkt(k)=dsin(k*theti2)
3364         enddo
3365         if (i.gt.3) then
3366 #ifdef OSF
3367           phii=phi(i)
3368           if (phii.ne.phii) phii=150.0
3369 #else
3370           phii=phi(i)
3371 #endif
3372           ityp1=ithetyp(itype(i-2))
3373           do k=1,nsingle
3374             cosph1(k)=dcos(k*phii)
3375             sinph1(k)=dsin(k*phii)
3376           enddo
3377         else
3378           phii=0.0d0
3379           ityp1=nthetyp+1
3380           do k=1,nsingle
3381             cosph1(k)=0.0d0
3382             sinph1(k)=0.0d0
3383           enddo
3384         endif
3385         if (i.lt.nres) then
3386 #ifdef OSF
3387           phii1=phi(i+1)
3388           if (phii1.ne.phii1) phii1=150.0
3389           phii1=pinorm(phii1)
3390 #else
3391           phii1=phi(i+1)
3392 #endif
3393           ityp3=ithetyp(itype(i))
3394           do k=1,nsingle
3395             cosph2(k)=dcos(k*phii1)
3396             sinph2(k)=dsin(k*phii1)
3397           enddo
3398         else
3399           phii1=0.0d0
3400           ityp3=nthetyp+1
3401           do k=1,nsingle
3402             cosph2(k)=0.0d0
3403             sinph2(k)=0.0d0
3404           enddo
3405         endif
3406         ethetai=aa0thet(ityp1,ityp2,ityp3)
3407         do k=1,ndouble
3408           do l=1,k-1
3409             ccl=cosph1(l)*cosph2(k-l)
3410             ssl=sinph1(l)*sinph2(k-l)
3411             scl=sinph1(l)*cosph2(k-l)
3412             csl=cosph1(l)*sinph2(k-l)
3413             cosph1ph2(l,k)=ccl-ssl
3414             cosph1ph2(k,l)=ccl+ssl
3415             sinph1ph2(l,k)=scl+csl
3416             sinph1ph2(k,l)=scl-csl
3417           enddo
3418         enddo
3419         if (lprn) then
3420         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
3421      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
3422         write (iout,*) "coskt and sinkt"
3423         do k=1,nntheterm
3424           write (iout,*) k,coskt(k),sinkt(k)
3425         enddo
3426         endif
3427         do k=1,ntheterm
3428           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
3429           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
3430      &      *coskt(k)
3431           if (lprn)
3432      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
3433      &     " ethetai",ethetai
3434         enddo
3435         if (lprn) then
3436         write (iout,*) "cosph and sinph"
3437         do k=1,nsingle
3438           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
3439         enddo
3440         write (iout,*) "cosph1ph2 and sinph2ph2"
3441         do k=2,ndouble
3442           do l=1,k-1
3443             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
3444      &         sinph1ph2(l,k),sinph1ph2(k,l)
3445           enddo
3446         enddo
3447         write(iout,*) "ethetai",ethetai
3448         endif
3449         do m=1,ntheterm2
3450           do k=1,nsingle
3451             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
3452      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
3453      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
3454      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
3455             ethetai=ethetai+sinkt(m)*aux
3456             dethetai=dethetai+0.5d0*m*aux*coskt(m)
3457             dephii=dephii+k*sinkt(m)*(
3458      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
3459      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
3460             dephii1=dephii1+k*sinkt(m)*(
3461      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
3462      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
3463             if (lprn)
3464      &      write (iout,*) "m",m," k",k," bbthet",
3465      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
3466      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
3467      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
3468      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3469           enddo
3470         enddo
3471         if (lprn)
3472      &  write(iout,*) "ethetai",ethetai
3473         do m=1,ntheterm3
3474           do k=2,ndouble
3475             do l=1,k-1
3476               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3477      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
3478      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3479      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
3480               ethetai=ethetai+sinkt(m)*aux
3481               dethetai=dethetai+0.5d0*m*coskt(m)*aux
3482               dephii=dephii+l*sinkt(m)*(
3483      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
3484      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3485      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
3486      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3487               dephii1=dephii1+(k-l)*sinkt(m)*(
3488      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
3489      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
3490      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
3491      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
3492               if (lprn) then
3493               write (iout,*) "m",m," k",k," l",l," ffthet",
3494      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
3495      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
3496      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
3497      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
3498               write (iout,*) cosph1ph2(l,k)*sinkt(m),
3499      &            cosph1ph2(k,l)*sinkt(m),
3500      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
3501               endif
3502             enddo
3503           enddo
3504         enddo
3505 10      continue
3506         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
3507      &   i,theta(i)*rad2deg,phii*rad2deg,
3508      &   phii1*rad2deg,ethetai
3509         etheta=etheta+ethetai
3510         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
3511         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
3512         gloc(nphi+i-2,icg)=wang*dethetai
3513       enddo
3514       return
3515       end
3516 #endif
3517 #ifdef CRYST_SC
3518 c-----------------------------------------------------------------------------
3519       subroutine esc(escloc)
3520 C Calculate the local energy of a side chain and its derivatives in the
3521 C corresponding virtual-bond valence angles THETA and the spherical angles
3522 C ALPHA and OMEGA.
3523       implicit real*8 (a-h,o-z)
3524       include 'DIMENSIONS'
3525       include 'COMMON.GEO'
3526       include 'COMMON.LOCAL'
3527       include 'COMMON.VAR'
3528       include 'COMMON.INTERACT'
3529       include 'COMMON.DERIV'
3530       include 'COMMON.CHAIN'
3531       include 'COMMON.IOUNITS'
3532       include 'COMMON.NAMES'
3533       include 'COMMON.FFIELD'
3534       include 'COMMON.CONTROL'
3535       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
3536      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
3537       common /sccalc/ time11,time12,time112,theti,it,nlobit
3538       delta=0.02d0*pi
3539       escloc=0.0D0
3540 c     write (iout,'(a)') 'ESC'
3541       do i=loc_start,loc_end
3542         it=itype(i)
3543         if (it.eq.10) goto 1
3544         nlobit=nlob(it)
3545 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
3546 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
3547         theti=theta(i+1)-pipol
3548         x(1)=dtan(theti)
3549         x(2)=alph(i)
3550         x(3)=omeg(i)
3551
3552         if (x(2).gt.pi-delta) then
3553           xtemp(1)=x(1)
3554           xtemp(2)=pi-delta
3555           xtemp(3)=x(3)
3556           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3557           xtemp(2)=pi
3558           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3559           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
3560      &        escloci,dersc(2))
3561           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3562      &        ddersc0(1),dersc(1))
3563           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
3564      &        ddersc0(3),dersc(3))
3565           xtemp(2)=pi-delta
3566           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3567           xtemp(2)=pi
3568           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3569           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
3570      &            dersc0(2),esclocbi,dersc02)
3571           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
3572      &            dersc12,dersc01)
3573           call splinthet(x(2),0.5d0*delta,ss,ssd)
3574           dersc0(1)=dersc01
3575           dersc0(2)=dersc02
3576           dersc0(3)=0.0d0
3577           do k=1,3
3578             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3579           enddo
3580           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3581 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3582 c    &             esclocbi,ss,ssd
3583           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3584 c         escloci=esclocbi
3585 c         write (iout,*) escloci
3586         else if (x(2).lt.delta) then
3587           xtemp(1)=x(1)
3588           xtemp(2)=delta
3589           xtemp(3)=x(3)
3590           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
3591           xtemp(2)=0.0d0
3592           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
3593           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
3594      &        escloci,dersc(2))
3595           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3596      &        ddersc0(1),dersc(1))
3597           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
3598      &        ddersc0(3),dersc(3))
3599           xtemp(2)=delta
3600           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
3601           xtemp(2)=0.0d0
3602           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
3603           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
3604      &            dersc0(2),esclocbi,dersc02)
3605           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
3606      &            dersc12,dersc01)
3607           dersc0(1)=dersc01
3608           dersc0(2)=dersc02
3609           dersc0(3)=0.0d0
3610           call splinthet(x(2),0.5d0*delta,ss,ssd)
3611           do k=1,3
3612             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
3613           enddo
3614           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
3615 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
3616 c    &             esclocbi,ss,ssd
3617           escloci=ss*escloci+(1.0d0-ss)*esclocbi
3618 c         write (iout,*) escloci
3619         else
3620           call enesc(x,escloci,dersc,ddummy,.false.)
3621         endif
3622
3623         escloc=escloc+escloci
3624         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
3625      &     'escloc',i,escloci
3626 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
3627
3628         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3629      &   wscloc*dersc(1)
3630         gloc(ialph(i,1),icg)=wscloc*dersc(2)
3631         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
3632     1   continue
3633       enddo
3634       return
3635       end
3636 C---------------------------------------------------------------------------
3637       subroutine enesc(x,escloci,dersc,ddersc,mixed)
3638       implicit real*8 (a-h,o-z)
3639       include 'DIMENSIONS'
3640       include 'COMMON.GEO'
3641       include 'COMMON.LOCAL'
3642       include 'COMMON.IOUNITS'
3643       common /sccalc/ time11,time12,time112,theti,it,nlobit
3644       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
3645       double precision contr(maxlob,-1:1)
3646       logical mixed
3647 c       write (iout,*) 'it=',it,' nlobit=',nlobit
3648         escloc_i=0.0D0
3649         do j=1,3
3650           dersc(j)=0.0D0
3651           if (mixed) ddersc(j)=0.0d0
3652         enddo
3653         x3=x(3)
3654
3655 C Because of periodicity of the dependence of the SC energy in omega we have
3656 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
3657 C To avoid underflows, first compute & store the exponents.
3658
3659         do iii=-1,1
3660
3661           x(3)=x3+iii*dwapi
3662
3663           do j=1,nlobit
3664             do k=1,3
3665               z(k)=x(k)-censc(k,j,it)
3666             enddo
3667             do k=1,3
3668               Axk=0.0D0
3669               do l=1,3
3670                 Axk=Axk+gaussc(l,k,j,it)*z(l)
3671               enddo
3672               Ax(k,j,iii)=Axk
3673             enddo
3674             expfac=0.0D0
3675             do k=1,3
3676               expfac=expfac+Ax(k,j,iii)*z(k)
3677             enddo
3678             contr(j,iii)=expfac
3679           enddo ! j
3680
3681         enddo ! iii
3682
3683         x(3)=x3
3684 C As in the case of ebend, we want to avoid underflows in exponentiation and
3685 C subsequent NaNs and INFs in energy calculation.
3686 C Find the largest exponent
3687         emin=contr(1,-1)
3688         do iii=-1,1
3689           do j=1,nlobit
3690             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
3691           enddo
3692         enddo
3693         emin=0.5D0*emin
3694 cd      print *,'it=',it,' emin=',emin
3695
3696 C Compute the contribution to SC energy and derivatives
3697         do iii=-1,1
3698
3699           do j=1,nlobit
3700 #ifdef OSF
3701             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
3702             if(adexp.ne.adexp) adexp=1.0
3703             expfac=dexp(adexp)
3704 #else
3705             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
3706 #endif
3707 cd          print *,'j=',j,' expfac=',expfac
3708             escloc_i=escloc_i+expfac
3709             do k=1,3
3710               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
3711             enddo
3712             if (mixed) then
3713               do k=1,3,2
3714                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
3715      &            +gaussc(k,2,j,it))*expfac
3716               enddo
3717             endif
3718           enddo
3719
3720         enddo ! iii
3721
3722         dersc(1)=dersc(1)/cos(theti)**2
3723         ddersc(1)=ddersc(1)/cos(theti)**2
3724         ddersc(3)=ddersc(3)
3725
3726         escloci=-(dlog(escloc_i)-emin)
3727         do j=1,3
3728           dersc(j)=dersc(j)/escloc_i
3729         enddo
3730         if (mixed) then
3731           do j=1,3,2
3732             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
3733           enddo
3734         endif
3735       return
3736       end
3737 C------------------------------------------------------------------------------
3738       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
3739       implicit real*8 (a-h,o-z)
3740       include 'DIMENSIONS'
3741       include 'COMMON.GEO'
3742       include 'COMMON.LOCAL'
3743       include 'COMMON.IOUNITS'
3744       common /sccalc/ time11,time12,time112,theti,it,nlobit
3745       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
3746       double precision contr(maxlob)
3747       logical mixed
3748
3749       escloc_i=0.0D0
3750
3751       do j=1,3
3752         dersc(j)=0.0D0
3753       enddo
3754
3755       do j=1,nlobit
3756         do k=1,2
3757           z(k)=x(k)-censc(k,j,it)
3758         enddo
3759         z(3)=dwapi
3760         do k=1,3
3761           Axk=0.0D0
3762           do l=1,3
3763             Axk=Axk+gaussc(l,k,j,it)*z(l)
3764           enddo
3765           Ax(k,j)=Axk
3766         enddo
3767         expfac=0.0D0
3768         do k=1,3
3769           expfac=expfac+Ax(k,j)*z(k)
3770         enddo
3771         contr(j)=expfac
3772       enddo ! j
3773
3774 C As in the case of ebend, we want to avoid underflows in exponentiation and
3775 C subsequent NaNs and INFs in energy calculation.
3776 C Find the largest exponent
3777       emin=contr(1)
3778       do j=1,nlobit
3779         if (emin.gt.contr(j)) emin=contr(j)
3780       enddo
3781       emin=0.5D0*emin
3782
3783 C Compute the contribution to SC energy and derivatives
3784
3785       dersc12=0.0d0
3786       do j=1,nlobit
3787         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
3788         escloc_i=escloc_i+expfac
3789         do k=1,2
3790           dersc(k)=dersc(k)+Ax(k,j)*expfac
3791         enddo
3792         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
3793      &            +gaussc(1,2,j,it))*expfac
3794         dersc(3)=0.0d0
3795       enddo
3796
3797       dersc(1)=dersc(1)/cos(theti)**2
3798       dersc12=dersc12/cos(theti)**2
3799       escloci=-(dlog(escloc_i)-emin)
3800       do j=1,2
3801         dersc(j)=dersc(j)/escloc_i
3802       enddo
3803       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
3804       return
3805       end
3806 #else
3807 c----------------------------------------------------------------------------------
3808       subroutine esc(escloc)
3809 C Calculate the local energy of a side chain and its derivatives in the
3810 C corresponding virtual-bond valence angles THETA and the spherical angles
3811 C ALPHA and OMEGA derived from AM1 all-atom calculations.
3812 C added by Urszula Kozlowska. 07/11/2007
3813 C
3814       implicit real*8 (a-h,o-z)
3815       include 'DIMENSIONS'
3816       include 'COMMON.GEO'
3817       include 'COMMON.LOCAL'
3818       include 'COMMON.VAR'
3819       include 'COMMON.SCROT'
3820       include 'COMMON.INTERACT'
3821       include 'COMMON.DERIV'
3822       include 'COMMON.CHAIN'
3823       include 'COMMON.IOUNITS'
3824       include 'COMMON.NAMES'
3825       include 'COMMON.FFIELD'
3826       include 'COMMON.CONTROL'
3827       include 'COMMON.VECTORS'
3828       double precision x_prime(3),y_prime(3),z_prime(3)
3829      &    , sumene,dsc_i,dp2_i,x(65),
3830      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
3831      &    de_dxx,de_dyy,de_dzz,de_dt
3832       double precision s1_t,s1_6_t,s2_t,s2_6_t
3833       double precision
3834      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
3835      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
3836      & dt_dCi(3),dt_dCi1(3)
3837       common /sccalc/ time11,time12,time112,theti,it,nlobit
3838       delta=0.02d0*pi
3839       escloc=0.0D0
3840       do i=loc_start,loc_end
3841         costtab(i+1) =dcos(theta(i+1))
3842         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
3843         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
3844         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
3845         cosfac2=0.5d0/(1.0d0+costtab(i+1))
3846         cosfac=dsqrt(cosfac2)
3847         sinfac2=0.5d0/(1.0d0-costtab(i+1))
3848         sinfac=dsqrt(sinfac2)
3849         it=itype(i)
3850         if (it.eq.10) goto 1
3851 c
3852 C  Compute the axes of tghe local cartesian coordinates system; store in
3853 c   x_prime, y_prime and z_prime
3854 c
3855         do j=1,3
3856           x_prime(j) = 0.00
3857           y_prime(j) = 0.00
3858           z_prime(j) = 0.00
3859         enddo
3860 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
3861 C     &   dc_norm(3,i+nres)
3862         do j = 1,3
3863           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
3864           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
3865         enddo
3866         do j = 1,3
3867           z_prime(j) = -uz(j,i-1)
3868         enddo
3869 c       write (2,*) "i",i
3870 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
3871 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
3872 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
3873 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
3874 c      & " xy",scalar(x_prime(1),y_prime(1)),
3875 c      & " xz",scalar(x_prime(1),z_prime(1)),
3876 c      & " yy",scalar(y_prime(1),y_prime(1)),
3877 c      & " yz",scalar(y_prime(1),z_prime(1)),
3878 c      & " zz",scalar(z_prime(1),z_prime(1))
3879 c
3880 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
3881 C to local coordinate system. Store in xx, yy, zz.
3882 c
3883         xx=0.0d0
3884         yy=0.0d0
3885         zz=0.0d0
3886         do j = 1,3
3887           xx = xx + x_prime(j)*dc_norm(j,i+nres)
3888           yy = yy + y_prime(j)*dc_norm(j,i+nres)
3889           zz = zz + z_prime(j)*dc_norm(j,i+nres)
3890         enddo
3891
3892         xxtab(i)=xx
3893         yytab(i)=yy
3894         zztab(i)=zz
3895 C
3896 C Compute the energy of the ith side cbain
3897 C
3898 c        write (2,*) "xx",xx," yy",yy," zz",zz
3899         it=itype(i)
3900         do j = 1,65
3901           x(j) = sc_parmin(j,it)
3902         enddo
3903 #ifdef CHECK_COORD
3904 Cc diagnostics - remove later
3905         xx1 = dcos(alph(2))
3906         yy1 = dsin(alph(2))*dcos(omeg(2))
3907         zz1 = -dsin(alph(2))*dsin(omeg(2))
3908         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
3909      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
3910      &    xx1,yy1,zz1
3911 C,"  --- ", xx_w,yy_w,zz_w
3912 c end diagnostics
3913 #endif
3914         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
3915      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
3916      &   + x(10)*yy*zz
3917         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
3918      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
3919      & + x(20)*yy*zz
3920         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
3921      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
3922      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
3923      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
3924      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
3925      &  +x(40)*xx*yy*zz
3926         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
3927      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
3928      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
3929      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
3930      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
3931      &  +x(60)*xx*yy*zz
3932         dsc_i   = 0.743d0+x(61)
3933         dp2_i   = 1.9d0+x(62)
3934         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
3935      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
3936         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
3937      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
3938         s1=(1+x(63))/(0.1d0 + dscp1)
3939         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
3940         s2=(1+x(65))/(0.1d0 + dscp2)
3941         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
3942         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
3943      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
3944 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
3945 c     &   sumene4,
3946 c     &   dscp1,dscp2,sumene
3947 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3948         escloc = escloc + sumene
3949 c        write (2,*) "i",i," escloc",sumene,escloc
3950 #ifdef DEBUG
3951 C
3952 C This section to check the numerical derivatives of the energy of ith side
3953 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
3954 C #define DEBUG in the code to turn it on.
3955 C
3956         write (2,*) "sumene               =",sumene
3957         aincr=1.0d-7
3958         xxsave=xx
3959         xx=xx+aincr
3960         write (2,*) xx,yy,zz
3961         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3962         de_dxx_num=(sumenep-sumene)/aincr
3963         xx=xxsave
3964         write (2,*) "xx+ sumene from enesc=",sumenep
3965         yysave=yy
3966         yy=yy+aincr
3967         write (2,*) xx,yy,zz
3968         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3969         de_dyy_num=(sumenep-sumene)/aincr
3970         yy=yysave
3971         write (2,*) "yy+ sumene from enesc=",sumenep
3972         zzsave=zz
3973         zz=zz+aincr
3974         write (2,*) xx,yy,zz
3975         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3976         de_dzz_num=(sumenep-sumene)/aincr
3977         zz=zzsave
3978         write (2,*) "zz+ sumene from enesc=",sumenep
3979         costsave=cost2tab(i+1)
3980         sintsave=sint2tab(i+1)
3981         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
3982         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
3983         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
3984         de_dt_num=(sumenep-sumene)/aincr
3985         write (2,*) " t+ sumene from enesc=",sumenep
3986         cost2tab(i+1)=costsave
3987         sint2tab(i+1)=sintsave
3988 C End of diagnostics section.
3989 #endif
3990 C
3991 C Compute the gradient of esc
3992 C
3993         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
3994         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
3995         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
3996         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
3997         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
3998         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
3999         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4000         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4001         pom1=(sumene3*sint2tab(i+1)+sumene1)
4002      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4003         pom2=(sumene4*cost2tab(i+1)+sumene2)
4004      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4005         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4006         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4007      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4008      &  +x(40)*yy*zz
4009         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4010         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4011      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4012      &  +x(60)*yy*zz
4013         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4014      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4015      &        +(pom1+pom2)*pom_dx
4016 #ifdef DEBUG
4017         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4018 #endif
4019 C
4020         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4021         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4022      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4023      &  +x(40)*xx*zz
4024         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4025         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4026      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4027      &  +x(59)*zz**2 +x(60)*xx*zz
4028         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4029      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4030      &        +(pom1-pom2)*pom_dy
4031 #ifdef DEBUG
4032         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4033 #endif
4034 C
4035         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4036      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4037      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4038      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4039      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4040      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4041      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4042      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4043 #ifdef DEBUG
4044         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4045 #endif
4046 C
4047         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4048      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4049      &  +pom1*pom_dt1+pom2*pom_dt2
4050 #ifdef DEBUG
4051         write(2,*), "de_dt = ", de_dt,de_dt_num
4052 #endif
4053 c
4054 C
4055        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4056        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4057        cosfac2xx=cosfac2*xx
4058        sinfac2yy=sinfac2*yy
4059        do k = 1,3
4060          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4061      &      vbld_inv(i+1)
4062          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4063      &      vbld_inv(i)
4064          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4065          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4066 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4067 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4068 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4069 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4070          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4071          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4072          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4073          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4074          dZZ_Ci1(k)=0.0d0
4075          dZZ_Ci(k)=0.0d0
4076          do j=1,3
4077            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4078            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4079          enddo
4080
4081          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4082          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4083          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4084 c
4085          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4086          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4087        enddo
4088
4089        do k=1,3
4090          dXX_Ctab(k,i)=dXX_Ci(k)
4091          dXX_C1tab(k,i)=dXX_Ci1(k)
4092          dYY_Ctab(k,i)=dYY_Ci(k)
4093          dYY_C1tab(k,i)=dYY_Ci1(k)
4094          dZZ_Ctab(k,i)=dZZ_Ci(k)
4095          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4096          dXX_XYZtab(k,i)=dXX_XYZ(k)
4097          dYY_XYZtab(k,i)=dYY_XYZ(k)
4098          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4099        enddo
4100
4101        do k = 1,3
4102 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4103 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4104 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4105 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4106 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4107 c     &    dt_dci(k)
4108 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4109 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4110          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4111      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4112          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4113      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4114          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4115      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4116        enddo
4117 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4118 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4119
4120 C to check gradient call subroutine check_grad
4121
4122     1 continue
4123       enddo
4124       return
4125       end
4126 c------------------------------------------------------------------------------
4127       double precision function enesc(x,xx,yy,zz,cost2,sint2)
4128       implicit none
4129       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
4130      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
4131       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4132      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4133      &   + x(10)*yy*zz
4134       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4135      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4136      & + x(20)*yy*zz
4137       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4138      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4139      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4140      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4141      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4142      &  +x(40)*xx*yy*zz
4143       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4144      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4145      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4146      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4147      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4148      &  +x(60)*xx*yy*zz
4149       dsc_i   = 0.743d0+x(61)
4150       dp2_i   = 1.9d0+x(62)
4151       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4152      &          *(xx*cost2+yy*sint2))
4153       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4154      &          *(xx*cost2-yy*sint2))
4155       s1=(1+x(63))/(0.1d0 + dscp1)
4156       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4157       s2=(1+x(65))/(0.1d0 + dscp2)
4158       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4159       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
4160      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
4161       enesc=sumene
4162       return
4163       end
4164 #endif
4165 c------------------------------------------------------------------------------
4166       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4167 C
4168 C This procedure calculates two-body contact function g(rij) and its derivative:
4169 C
4170 C           eps0ij                                     !       x < -1
4171 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4172 C            0                                         !       x > 1
4173 C
4174 C where x=(rij-r0ij)/delta
4175 C
4176 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4177 C
4178       implicit none
4179       double precision rij,r0ij,eps0ij,fcont,fprimcont
4180       double precision x,x2,x4,delta
4181 c     delta=0.02D0*r0ij
4182 c      delta=0.2D0*r0ij
4183       x=(rij-r0ij)/delta
4184       if (x.lt.-1.0D0) then
4185         fcont=eps0ij
4186         fprimcont=0.0D0
4187       else if (x.le.1.0D0) then
4188         x2=x*x
4189         x4=x2*x2
4190         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4191         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4192       else
4193         fcont=0.0D0
4194         fprimcont=0.0D0
4195       endif
4196       return
4197       end
4198 c------------------------------------------------------------------------------
4199       subroutine splinthet(theti,delta,ss,ssder)
4200       implicit real*8 (a-h,o-z)
4201       include 'DIMENSIONS'
4202       include 'COMMON.VAR'
4203       include 'COMMON.GEO'
4204       thetup=pi-delta
4205       thetlow=delta
4206       if (theti.gt.pipol) then
4207         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4208       else
4209         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4210         ssder=-ssder
4211       endif
4212       return
4213       end
4214 c------------------------------------------------------------------------------
4215       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4216       implicit none
4217       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4218       double precision ksi,ksi2,ksi3,a1,a2,a3
4219       a1=fprim0*delta/(f1-f0)
4220       a2=3.0d0-2.0d0*a1
4221       a3=a1-2.0d0
4222       ksi=(x-x0)/delta
4223       ksi2=ksi*ksi
4224       ksi3=ksi2*ksi
4225       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
4226       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
4227       return
4228       end
4229 c------------------------------------------------------------------------------
4230       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
4231       implicit none
4232       double precision x,x0,delta,f0x,f1x,fprim0x,fx
4233       double precision ksi,ksi2,ksi3,a1,a2,a3
4234       ksi=(x-x0)/delta
4235       ksi2=ksi*ksi
4236       ksi3=ksi2*ksi
4237       a1=fprim0x*delta
4238       a2=3*(f1x-f0x)-2*fprim0x*delta
4239       a3=fprim0x*delta-2*(f1x-f0x)
4240       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
4241       return
4242       end
4243 C-----------------------------------------------------------------------------
4244 #ifdef CRYST_TOR
4245 C-----------------------------------------------------------------------------
4246       subroutine etor(etors,edihcnstr)
4247       implicit real*8 (a-h,o-z)
4248       include 'DIMENSIONS'
4249       include 'COMMON.VAR'
4250       include 'COMMON.GEO'
4251       include 'COMMON.LOCAL'
4252       include 'COMMON.TORSION'
4253       include 'COMMON.INTERACT'
4254       include 'COMMON.DERIV'
4255       include 'COMMON.CHAIN'
4256       include 'COMMON.NAMES'
4257       include 'COMMON.IOUNITS'
4258       include 'COMMON.FFIELD'
4259       include 'COMMON.TORCNSTR'
4260       include 'COMMON.CONTROL'
4261       logical lprn
4262 C Set lprn=.true. for debugging
4263       lprn=.false.
4264 c      lprn=.true.
4265       etors=0.0D0
4266       do i=iphi_start,iphi_end
4267       etors_ii=0.0D0
4268         itori=itortyp(itype(i-2))
4269         itori1=itortyp(itype(i-1))
4270         phii=phi(i)
4271         gloci=0.0D0
4272 C Proline-Proline pair is a special case...
4273         if (itori.eq.3 .and. itori1.eq.3) then
4274           if (phii.gt.-dwapi3) then
4275             cosphi=dcos(3*phii)
4276             fac=1.0D0/(1.0D0-cosphi)
4277             etorsi=v1(1,3,3)*fac
4278             etorsi=etorsi+etorsi
4279             etors=etors+etorsi-v1(1,3,3)
4280             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
4281             gloci=gloci-3*fac*etorsi*dsin(3*phii)
4282           endif
4283           do j=1,3
4284             v1ij=v1(j+1,itori,itori1)
4285             v2ij=v2(j+1,itori,itori1)
4286             cosphi=dcos(j*phii)
4287             sinphi=dsin(j*phii)
4288             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4289             if (energy_dec) etors_ii=etors_ii+
4290      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4291             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4292           enddo
4293         else
4294           do j=1,nterm_old
4295             v1ij=v1(j,itori,itori1)
4296             v2ij=v2(j,itori,itori1)
4297             cosphi=dcos(j*phii)
4298             sinphi=dsin(j*phii)
4299             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4300             if (energy_dec) etors_ii=etors_ii+
4301      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
4302             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4303           enddo
4304         endif
4305         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4306              'etor',i,etors_ii
4307         if (lprn)
4308      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4309      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4310      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4311         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
4312 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4313       enddo
4314 ! 6/20/98 - dihedral angle constraints
4315       edihcnstr=0.0d0
4316       do i=1,ndih_constr
4317         itori=idih_constr(i)
4318         phii=phi(itori)
4319         difi=phii-phi0(i)
4320         if (difi.gt.drange(i)) then
4321           difi=difi-drange(i)
4322           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4323           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4324         else if (difi.lt.-drange(i)) then
4325           difi=difi+drange(i)
4326           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4327           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4328         endif
4329 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
4330 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4331       enddo
4332 !      write (iout,*) 'edihcnstr',edihcnstr
4333       return
4334       end
4335 c------------------------------------------------------------------------------
4336       subroutine etor_d(etors_d)
4337       etors_d=0.0d0
4338       return
4339       end
4340 c----------------------------------------------------------------------------
4341 #else
4342       subroutine etor(etors,edihcnstr)
4343       implicit real*8 (a-h,o-z)
4344       include 'DIMENSIONS'
4345       include 'COMMON.VAR'
4346       include 'COMMON.GEO'
4347       include 'COMMON.LOCAL'
4348       include 'COMMON.TORSION'
4349       include 'COMMON.INTERACT'
4350       include 'COMMON.DERIV'
4351       include 'COMMON.CHAIN'
4352       include 'COMMON.NAMES'
4353       include 'COMMON.IOUNITS'
4354       include 'COMMON.FFIELD'
4355       include 'COMMON.TORCNSTR'
4356       include 'COMMON.CONTROL'
4357       logical lprn
4358 C Set lprn=.true. for debugging
4359       lprn=.false.
4360 c     lprn=.true.
4361       etors=0.0D0
4362       do i=iphi_start,iphi_end
4363       etors_ii=0.0D0
4364         itori=itortyp(itype(i-2))
4365         itori1=itortyp(itype(i-1))
4366         phii=phi(i)
4367         gloci=0.0D0
4368 C Regular cosine and sine terms
4369         do j=1,nterm(itori,itori1)
4370           v1ij=v1(j,itori,itori1)
4371           v2ij=v2(j,itori,itori1)
4372           cosphi=dcos(j*phii)
4373           sinphi=dsin(j*phii)
4374           etors=etors+v1ij*cosphi+v2ij*sinphi
4375           if (energy_dec) etors_ii=etors_ii+
4376      &                v1ij*cosphi+v2ij*sinphi
4377           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4378         enddo
4379 C Lorentz terms
4380 C                         v1
4381 C  E = SUM ----------------------------------- - v1
4382 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
4383 C
4384         cosphi=dcos(0.5d0*phii)
4385         sinphi=dsin(0.5d0*phii)
4386         do j=1,nlor(itori,itori1)
4387           vl1ij=vlor1(j,itori,itori1)
4388           vl2ij=vlor2(j,itori,itori1)
4389           vl3ij=vlor3(j,itori,itori1)
4390           pom=vl2ij*cosphi+vl3ij*sinphi
4391           pom1=1.0d0/(pom*pom+1.0d0)
4392           etors=etors+vl1ij*pom1
4393           if (energy_dec) etors_ii=etors_ii+
4394      &                vl1ij*pom1
4395           pom=-pom*pom1*pom1
4396           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
4397         enddo
4398 C Subtract the constant term
4399         etors=etors-v0(itori,itori1)
4400           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4401      &         'etor',i,etors_ii-v0(itori,itori1)
4402         if (lprn)
4403      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4404      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4405      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
4406         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
4407 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
4408       enddo
4409 ! 6/20/98 - dihedral angle constraints
4410       edihcnstr=0.0d0
4411 c      do i=1,ndih_constr
4412       do i=idihconstr_start,idihconstr_end
4413         itori=idih_constr(i)
4414         phii=phi(itori)
4415         difi=pinorm(phii-phi0(i))
4416         if (difi.gt.drange(i)) then
4417           difi=difi-drange(i)
4418           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4419           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4420         else if (difi.lt.-drange(i)) then
4421           difi=difi+drange(i)
4422           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
4423           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
4424         else
4425           difi=0.0
4426         endif
4427 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
4428 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
4429 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
4430       enddo
4431 cd       write (iout,*) 'edihcnstr',edihcnstr
4432       return
4433       end
4434 c----------------------------------------------------------------------------
4435       subroutine etor_d(etors_d)
4436 C 6/23/01 Compute double torsional energy
4437       implicit real*8 (a-h,o-z)
4438       include 'DIMENSIONS'
4439       include 'COMMON.VAR'
4440       include 'COMMON.GEO'
4441       include 'COMMON.LOCAL'
4442       include 'COMMON.TORSION'
4443       include 'COMMON.INTERACT'
4444       include 'COMMON.DERIV'
4445       include 'COMMON.CHAIN'
4446       include 'COMMON.NAMES'
4447       include 'COMMON.IOUNITS'
4448       include 'COMMON.FFIELD'
4449       include 'COMMON.TORCNSTR'
4450       logical lprn
4451 C Set lprn=.true. for debugging
4452       lprn=.false.
4453 c     lprn=.true.
4454       etors_d=0.0D0
4455       do i=iphid_start,iphid_end
4456         itori=itortyp(itype(i-2))
4457         itori1=itortyp(itype(i-1))
4458         itori2=itortyp(itype(i))
4459         phii=phi(i)
4460         phii1=phi(i+1)
4461         gloci1=0.0D0
4462         gloci2=0.0D0
4463 C Regular cosine and sine terms
4464         do j=1,ntermd_1(itori,itori1,itori2)
4465           v1cij=v1c(1,j,itori,itori1,itori2)
4466           v1sij=v1s(1,j,itori,itori1,itori2)
4467           v2cij=v1c(2,j,itori,itori1,itori2)
4468           v2sij=v1s(2,j,itori,itori1,itori2)
4469           cosphi1=dcos(j*phii)
4470           sinphi1=dsin(j*phii)
4471           cosphi2=dcos(j*phii1)
4472           sinphi2=dsin(j*phii1)
4473           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
4474      &     v2cij*cosphi2+v2sij*sinphi2
4475           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
4476           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
4477         enddo
4478         do k=2,ntermd_2(itori,itori1,itori2)
4479           do l=1,k-1
4480             v1cdij = v2c(k,l,itori,itori1,itori2)
4481             v2cdij = v2c(l,k,itori,itori1,itori2)
4482             v1sdij = v2s(k,l,itori,itori1,itori2)
4483             v2sdij = v2s(l,k,itori,itori1,itori2)
4484             cosphi1p2=dcos(l*phii+(k-l)*phii1)
4485             cosphi1m2=dcos(l*phii-(k-l)*phii1)
4486             sinphi1p2=dsin(l*phii+(k-l)*phii1)
4487             sinphi1m2=dsin(l*phii-(k-l)*phii1)
4488             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
4489      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
4490             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
4491      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
4492             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
4493      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
4494           enddo
4495         enddo
4496         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
4497         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
4498       enddo
4499       return
4500       end
4501 #endif
4502 c------------------------------------------------------------------------------
4503       subroutine eback_sc_corr(esccor)
4504 c 7/21/2007 Correlations between the backbone-local and side-chain-local
4505 c        conformational states; temporarily implemented as differences
4506 c        between UNRES torsional potentials (dependent on three types of
4507 c        residues) and the torsional potentials dependent on all 20 types
4508 c        of residues computed from AM1  energy surfaces of terminally-blocked
4509 c        amino-acid residues.
4510       implicit real*8 (a-h,o-z)
4511       include 'DIMENSIONS'
4512       include 'COMMON.VAR'
4513       include 'COMMON.GEO'
4514       include 'COMMON.LOCAL'
4515       include 'COMMON.TORSION'
4516       include 'COMMON.SCCOR'
4517       include 'COMMON.INTERACT'
4518       include 'COMMON.DERIV'
4519       include 'COMMON.CHAIN'
4520       include 'COMMON.NAMES'
4521       include 'COMMON.IOUNITS'
4522       include 'COMMON.FFIELD'
4523       include 'COMMON.CONTROL'
4524       logical lprn
4525 C Set lprn=.true. for debugging
4526       lprn=.false.
4527 c      lprn=.true.
4528 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
4529       esccor=0.0D0
4530       do i=iphi_start,iphi_end
4531         esccor_ii=0.0D0
4532         itori=itype(i-2)
4533         itori1=itype(i-1)
4534         phii=phi(i)
4535         gloci=0.0D0
4536         do j=1,nterm_sccor
4537           v1ij=v1sccor(j,itori,itori1)
4538           v2ij=v2sccor(j,itori,itori1)
4539           cosphi=dcos(j*phii)
4540           sinphi=dsin(j*phii)
4541           esccor=esccor+v1ij*cosphi+v2ij*sinphi
4542           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
4543         enddo
4544         if (lprn)
4545      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
4546      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
4547      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
4548         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
4549       enddo
4550       return
4551       end
4552 c----------------------------------------------------------------------------
4553       subroutine multibody(ecorr)
4554 C This subroutine calculates multi-body contributions to energy following
4555 C the idea of Skolnick et al. If side chains I and J make a contact and
4556 C at the same time side chains I+1 and J+1 make a contact, an extra
4557 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
4558       implicit real*8 (a-h,o-z)
4559       include 'DIMENSIONS'
4560       include 'COMMON.IOUNITS'
4561       include 'COMMON.DERIV'
4562       include 'COMMON.INTERACT'
4563       include 'COMMON.CONTACTS'
4564       double precision gx(3),gx1(3)
4565       logical lprn
4566
4567 C Set lprn=.true. for debugging
4568       lprn=.false.
4569
4570       if (lprn) then
4571         write (iout,'(a)') 'Contact function values:'
4572         do i=nnt,nct-2
4573           write (iout,'(i2,20(1x,i2,f10.5))')
4574      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
4575         enddo
4576       endif
4577       ecorr=0.0D0
4578       do i=nnt,nct
4579         do j=1,3
4580           gradcorr(j,i)=0.0D0
4581           gradxorr(j,i)=0.0D0
4582         enddo
4583       enddo
4584       do i=nnt,nct-2
4585
4586         DO ISHIFT = 3,4
4587
4588         i1=i+ishift
4589         num_conti=num_cont(i)
4590         num_conti1=num_cont(i1)
4591         do jj=1,num_conti
4592           j=jcont(jj,i)
4593           do kk=1,num_conti1
4594             j1=jcont(kk,i1)
4595             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
4596 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4597 cd   &                   ' ishift=',ishift
4598 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
4599 C The system gains extra energy.
4600               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
4601             endif   ! j1==j+-ishift
4602           enddo     ! kk
4603         enddo       ! jj
4604
4605         ENDDO ! ISHIFT
4606
4607       enddo         ! i
4608       return
4609       end
4610 c------------------------------------------------------------------------------
4611       double precision function esccorr(i,j,k,l,jj,kk)
4612       implicit real*8 (a-h,o-z)
4613       include 'DIMENSIONS'
4614       include 'COMMON.IOUNITS'
4615       include 'COMMON.DERIV'
4616       include 'COMMON.INTERACT'
4617       include 'COMMON.CONTACTS'
4618       double precision gx(3),gx1(3)
4619       logical lprn
4620       lprn=.false.
4621       eij=facont(jj,i)
4622       ekl=facont(kk,k)
4623 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
4624 C Calculate the multi-body contribution to energy.
4625 C Calculate multi-body contributions to the gradient.
4626 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
4627 cd   & k,l,(gacont(m,kk,k),m=1,3)
4628       do m=1,3
4629         gx(m) =ekl*gacont(m,jj,i)
4630         gx1(m)=eij*gacont(m,kk,k)
4631         gradxorr(m,i)=gradxorr(m,i)-gx(m)
4632         gradxorr(m,j)=gradxorr(m,j)+gx(m)
4633         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
4634         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
4635       enddo
4636       do m=i,j-1
4637         do ll=1,3
4638           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
4639         enddo
4640       enddo
4641       do m=k,l-1
4642         do ll=1,3
4643           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
4644         enddo
4645       enddo
4646       esccorr=-eij*ekl
4647       return
4648       end
4649 c------------------------------------------------------------------------------
4650 #ifdef MPI
4651       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
4652       implicit real*8 (a-h,o-z)
4653       include 'DIMENSIONS'
4654       integer dimen1,dimen2,atom,indx
4655       double precision buffer(dimen1,dimen2)
4656       double precision zapas
4657       common /contacts_hb/ zapas(3,maxconts,maxres,8),
4658      &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
4659      &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
4660      &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
4661       num_kont=num_cont_hb(atom)
4662       do i=1,num_kont
4663         do k=1,8
4664           do j=1,3
4665             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
4666           enddo ! j
4667         enddo ! k
4668         buffer(i,indx+25)=facont_hb(i,atom)
4669         buffer(i,indx+26)=ees0p(i,atom)
4670         buffer(i,indx+27)=ees0m(i,atom)
4671         buffer(i,indx+28)=d_cont(i,atom)
4672         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
4673       enddo ! i
4674       buffer(1,indx+30)=dfloat(num_kont)
4675       return
4676       end
4677 c------------------------------------------------------------------------------
4678       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
4679       implicit real*8 (a-h,o-z)
4680       include 'DIMENSIONS'
4681       integer dimen1,dimen2,atom,indx
4682       double precision buffer(dimen1,dimen2)
4683       double precision zapas
4684       common /contacts_hb/ zapas(3,maxconts,maxres,8),
4685      &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
4686      &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
4687      &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
4688       num_kont=buffer(1,indx+30)
4689       num_kont_old=num_cont_hb(atom)
4690       num_cont_hb(atom)=num_kont+num_kont_old
4691       do i=1,num_kont
4692         ii=i+num_kont_old
4693         do k=1,8
4694           do j=1,3
4695             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
4696           enddo ! j
4697         enddo ! k
4698         facont_hb(ii,atom)=buffer(i,indx+25)
4699         ees0p(ii,atom)=buffer(i,indx+26)
4700         ees0m(ii,atom)=buffer(i,indx+27)
4701         d_cont(i,atom)=buffer(i,indx+28)
4702         jcont_hb(ii,atom)=buffer(i,indx+29)
4703       enddo ! i
4704       return
4705       end
4706 c------------------------------------------------------------------------------
4707 #endif
4708       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
4709 C This subroutine calculates multi-body contributions to hydrogen-bonding
4710       implicit real*8 (a-h,o-z)
4711       include 'DIMENSIONS'
4712       include 'COMMON.IOUNITS'
4713 #ifdef MPI
4714       include "mpif.h"
4715       parameter (max_cont=maxconts)
4716       parameter (max_dim=2*(8*3+6))
4717       parameter (msglen1=max_cont*max_dim)
4718       parameter (msglen2=2*msglen1)
4719       integer source,CorrelType,CorrelID,Error
4720       double precision buffer(max_cont,max_dim)
4721       integer status(MPI_STATUS_SIZE)
4722 #endif
4723       include 'COMMON.SETUP'
4724       include 'COMMON.FFIELD'
4725       include 'COMMON.DERIV'
4726       include 'COMMON.INTERACT'
4727       include 'COMMON.CONTACTS'
4728       include 'COMMON.CONTROL'
4729       double precision gx(3),gx1(3),time00
4730       logical lprn,ldone
4731
4732 C Set lprn=.true. for debugging
4733       lprn=.false.
4734 #ifdef MPI
4735       n_corr=0
4736       n_corr1=0
4737       if (nfgtasks.le.1) goto 30
4738       if (lprn) then
4739         write (iout,'(a)') 'Contact function values:'
4740         do i=nnt,nct-2
4741           write (iout,'(2i3,50(1x,i2,f5.2))')
4742      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4743      &    j=1,num_cont_hb(i))
4744         enddo
4745       endif
4746 C Caution! Following code assumes that electrostatic interactions concerning
4747 C a given atom are split among at most two processors!
4748       CorrelType=477
4749       CorrelID=fg_rank+1
4750       ldone=.false.
4751       do i=1,max_cont
4752         do j=1,max_dim
4753           buffer(i,j)=0.0D0
4754         enddo
4755       enddo
4756       mm=mod(fg_rank,2)
4757 c      write (*,*) 'MyRank',MyRank,' mm',mm
4758       if (mm) 20,20,10
4759    10 continue
4760 c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4761       if (fg_rank.gt.0) then
4762 C Send correlation contributions to the preceding processor
4763         msglen=msglen1
4764         nn=num_cont_hb(iatel_s)
4765         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4766 c        write (*,*) 'The BUFFER array:'
4767 c        do i=1,nn
4768 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
4769 c        enddo
4770         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4771           msglen=msglen2
4772           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
4773 C Clear the contacts of the atom passed to the neighboring processor
4774         nn=num_cont_hb(iatel_s+1)
4775 c        do i=1,nn
4776 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
4777 c        enddo
4778             num_cont_hb(iatel_s)=0
4779         endif
4780 cd      write (iout,*) 'Processor ',fg_rank,MyRank,
4781 cd   & ' is sending correlation contribution to processor',fg_rank-1,
4782 cd   & ' msglen=',msglen
4783 c        write (*,*) 'Processor ',fg_rank,MyRank,
4784 c     & ' is sending correlation contribution to processor',fg_rank-1,
4785 c     & ' msglen=',msglen,' CorrelType=',CorrelType
4786         time00=MPI_Wtime()
4787         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1,
4788      &    CorrelType,FG_COMM,IERROR)
4789         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
4790 cd      write (iout,*) 'Processor ',fg_rank,
4791 cd   & ' has sent correlation contribution to processor',fg_rank-1,
4792 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4793 c        write (*,*) 'Processor ',fg_rank,
4794 c     & ' has sent correlation contribution to processor',fg_rank-1,
4795 c     & ' msglen=',msglen,' CorrelID=',CorrelID
4796 c        msglen=msglen1
4797       endif ! (fg_rank.gt.0)
4798       if (ldone) goto 30
4799       ldone=.true.
4800    20 continue
4801 c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
4802       if (fg_rank.lt.nfgtasks-1) then
4803 C Receive correlation contributions from the next processor
4804         msglen=msglen1
4805         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
4806 cd      write (iout,*) 'Processor',fg_rank,
4807 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
4808 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4809 c        write (*,*) 'Processor',fg_rank,
4810 c     &' is receiving correlation contribution from processor',fg_rank+1,
4811 c     & ' msglen=',msglen,' CorrelType=',CorrelType
4812         time00=MPI_Wtime()
4813         nbytes=-1
4814         do while (nbytes.le.0)
4815           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
4816           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
4817         enddo
4818 c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
4819         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION,
4820      &    fg_rank+1,CorrelType,FG_COMM,status,IERROR)
4821         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
4822 c        write (*,*) 'Processor',fg_rank,
4823 c     &' has received correlation contribution from processor',fg_rank+1,
4824 c     & ' msglen=',msglen,' nbytes=',nbytes
4825 c        write (*,*) 'The received BUFFER array:'
4826 c        do i=1,max_cont
4827 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
4828 c        enddo
4829         if (msglen.eq.msglen1) then
4830           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
4831         else if (msglen.eq.msglen2)  then
4832           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
4833           call unpack_buffer(max_cont,max_dim,iatel_e+1,30,buffer)
4834         else
4835           write (iout,*)
4836      & 'ERROR!!!! message length changed while processing correlations.'
4837           write (*,*)
4838      & 'ERROR!!!! message length changed while processing correlations.'
4839           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
4840         endif ! msglen.eq.msglen1
4841       endif ! fg_rank.lt.nfgtasks-1
4842       if (ldone) goto 30
4843       ldone=.true.
4844       goto 10
4845    30 continue
4846 #endif
4847       if (lprn) then
4848         write (iout,'(a)') 'Contact function values:'
4849         do i=nnt,nct-2
4850           write (iout,'(2i3,50(1x,i2,f5.2))')
4851      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4852      &    j=1,num_cont_hb(i))
4853         enddo
4854       endif
4855       ecorr=0.0D0
4856 C Remove the loop below after debugging !!!
4857       do i=nnt,nct
4858         do j=1,3
4859           gradcorr(j,i)=0.0D0
4860           gradxorr(j,i)=0.0D0
4861         enddo
4862       enddo
4863 C Calculate the local-electrostatic correlation terms
4864       do i=iatel_s,iatel_e+1
4865         i1=i+1
4866         num_conti=num_cont_hb(i)
4867         num_conti1=num_cont_hb(i+1)
4868         do jj=1,num_conti
4869           j=jcont_hb(jj,i)
4870           do kk=1,num_conti1
4871             j1=jcont_hb(kk,i1)
4872 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4873 c     &         ' jj=',jj,' kk=',kk
4874             if (j1.eq.j+1 .or. j1.eq.j-1) then
4875 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
4876 C The system gains extra energy.
4877               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
4878               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4879      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
4880               n_corr=n_corr+1
4881             else if (j1.eq.j) then
4882 C Contacts I-J and I-(J+1) occur simultaneously.
4883 C The system loses extra energy.
4884 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
4885             endif
4886           enddo ! kk
4887           do kk=1,num_conti
4888             j1=jcont_hb(kk,i)
4889 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
4890 c    &         ' jj=',jj,' kk=',kk
4891             if (j1.eq.j+1) then
4892 C Contacts I-J and (I+1)-J occur simultaneously.
4893 C The system loses extra energy.
4894 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
4895             endif ! j1==j+1
4896           enddo ! kk
4897         enddo ! jj
4898       enddo ! i
4899       return
4900       end
4901 c------------------------------------------------------------------------------
4902       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
4903      &  n_corr1)
4904 C This subroutine calculates multi-body contributions to hydrogen-bonding
4905       implicit real*8 (a-h,o-z)
4906       include 'DIMENSIONS'
4907       include 'COMMON.IOUNITS'
4908 #ifdef MPI
4909       include 'mpif.h'
4910       parameter (max_cont=maxconts)
4911       parameter (max_dim=2*(8*3+6))
4912 c      parameter (msglen1=max_cont*max_dim*4)
4913       parameter (msglen1=max_cont*max_dim/2)
4914       parameter (msglen2=2*msglen1)
4915       integer source,CorrelType,CorrelID,Error
4916       double precision buffer(max_cont,max_dim)
4917       integer status(MPI_STATUS_SIZE)
4918 #endif
4919       include 'COMMON.SETUP'
4920       include 'COMMON.FFIELD'
4921       include 'COMMON.DERIV'
4922       include 'COMMON.INTERACT'
4923       include 'COMMON.CONTACTS'
4924       include 'COMMON.CONTROL'
4925       double precision gx(3),gx1(3)
4926       logical lprn,ldone
4927 C Set lprn=.true. for debugging
4928       lprn=.false.
4929       eturn6=0.0d0
4930 #ifdef MPI
4931       n_corr=0
4932       n_corr1=0
4933       if (fgProcs.le.1) goto 30
4934       if (lprn) then
4935         write (iout,'(a)') 'Contact function values:'
4936         do i=nnt,nct-2
4937           write (iout,'(2i3,50(1x,i2,f5.2))')
4938      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
4939      &    j=1,num_cont_hb(i))
4940         enddo
4941       endif
4942 C Caution! Following code assumes that electrostatic interactions concerning
4943 C a given atom are split among at most two processors!
4944       CorrelType=477
4945       CorrelID=MyID+1
4946       ldone=.false.
4947       do i=1,max_cont
4948         do j=1,max_dim
4949           buffer(i,j)=0.0D0
4950         enddo
4951       enddo
4952       mm=mod(MyRank,2)
4953 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
4954       if (mm) 20,20,10
4955    10 continue
4956 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
4957       if (MyRank.gt.0) then
4958 C Send correlation contributions to the preceding processor
4959         msglen=msglen1
4960         nn=num_cont_hb(iatel_s)
4961         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
4962 cd      write (iout,*) 'The BUFFER array:'
4963 cd      do i=1,nn
4964 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
4965 cd      enddo
4966         if (ielstart(iatel_s).gt.iatel_s+ispp) then
4967           msglen=msglen2
4968             call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
4969 C Clear the contacts of the atom passed to the neighboring processor
4970         nn=num_cont_hb(iatel_s+1)
4971 cd      do i=1,nn
4972 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
4973 cd      enddo
4974             num_cont_hb(iatel_s)=0
4975         endif
4976 cd      write (*,*) 'Processor ',fg_rank,MyRank,
4977 cd   & ' is sending correlation contribution to processor',fg_rank-1,
4978 cd   & ' msglen=',msglen
4979 cd      write (*,*) 'Processor ',MyID,MyRank,
4980 cd   & ' is sending correlation contribution to processor',fg_rank-1,
4981 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
4982         time00=MPI_Wtime()
4983         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1,
4984      &     CorrelType,FG_COMM,IERROR)
4985         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
4986 cd      write (*,*) 'Processor ',fg_rank,MyRank,
4987 cd   & ' has sent correlation contribution to processor',fg_rank-1,
4988 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4989 cd      write (*,*) 'Processor ',fg_rank,
4990 cd   & ' has sent correlation contribution to processor',fg_rank-1,
4991 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
4992         msglen=msglen1
4993       endif ! (MyRank.gt.0)
4994       if (ldone) goto 30
4995       ldone=.true.
4996    20 continue
4997 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
4998       if (fg_rank.lt.nfgtasks-1) then
4999 C Receive correlation contributions from the next processor
5000         msglen=msglen1
5001         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5002 cd      write (iout,*) 'Processor',fg_rank,
5003 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5004 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5005 cd      write (*,*) 'Processor',fg_rank,
5006 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5007 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5008         time00=MPI_Wtime()
5009         nbytes=-1
5010         do while (nbytes.le.0)
5011           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5012           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
5013         enddo
5014 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5015         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION,
5016      &    fg_rank+1,CorrelType,status,IERROR)
5017         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5018 cd      write (iout,*) 'Processor',fg_rank,
5019 cd   & ' has received correlation contribution from processor',fg_rank+1,
5020 cd   & ' msglen=',msglen,' nbytes=',nbytes
5021 cd      write (iout,*) 'The received BUFFER array:'
5022 cd      do i=1,max_cont
5023 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5024 cd      enddo
5025         if (msglen.eq.msglen1) then
5026           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5027         else if (msglen.eq.msglen2)  then
5028           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5029           call unpack_buffer(max_cont,max_dim,iatel_e+1,30,buffer)
5030         else
5031           write (iout,*)
5032      & 'ERROR!!!! message length changed while processing correlations.'
5033           write (*,*)
5034      & 'ERROR!!!! message length changed while processing correlations.'
5035           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
5036         endif ! msglen.eq.msglen1
5037       endif ! fg_rank.lt.nfgtasks-1
5038       if (ldone) goto 30
5039       ldone=.true.
5040       goto 10
5041    30 continue
5042 #endif
5043       if (lprn) then
5044         write (iout,'(a)') 'Contact function values:'
5045         do i=nnt,nct-2
5046           write (iout,'(2i3,50(1x,i2,f5.2))')
5047      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5048      &    j=1,num_cont_hb(i))
5049         enddo
5050       endif
5051       ecorr=0.0D0
5052       ecorr5=0.0d0
5053       ecorr6=0.0d0
5054 C Remove the loop below after debugging !!!
5055       do i=nnt,nct
5056         do j=1,3
5057           gradcorr(j,i)=0.0D0
5058           gradxorr(j,i)=0.0D0
5059         enddo
5060       enddo
5061 C Calculate the dipole-dipole interaction energies
5062       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5063       do i=iatel_s,iatel_e+1
5064         num_conti=num_cont_hb(i)
5065         do jj=1,num_conti
5066           j=jcont_hb(jj,i)
5067 #ifdef MOMENT
5068           call dipole(i,j,jj)
5069 #endif
5070         enddo
5071       enddo
5072       endif
5073 C Calculate the local-electrostatic correlation terms
5074       do i=iatel_s,iatel_e+1
5075         i1=i+1
5076         num_conti=num_cont_hb(i)
5077         num_conti1=num_cont_hb(i+1)
5078         do jj=1,num_conti
5079           j=jcont_hb(jj,i)
5080           do kk=1,num_conti1
5081             j1=jcont_hb(kk,i1)
5082 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5083 c     &         ' jj=',jj,' kk=',kk
5084             if (j1.eq.j+1 .or. j1.eq.j-1) then
5085 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5086 C The system gains extra energy.
5087               n_corr=n_corr+1
5088               sqd1=dsqrt(d_cont(jj,i))
5089               sqd2=dsqrt(d_cont(kk,i1))
5090               sred_geom = sqd1*sqd2
5091               IF (sred_geom.lt.cutoff_corr) THEN
5092                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5093      &            ekont,fprimcont)
5094 cd               write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5095 cd     &         ' jj=',jj,' kk=',kk
5096                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5097                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5098                 do l=1,3
5099                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5100                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5101                 enddo
5102                 n_corr1=n_corr1+1
5103 cd               write (iout,*) 'sred_geom=',sred_geom,
5104 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5105                 call calc_eello(i,j,i+1,j1,jj,kk)
5106                 if (wcorr4.gt.0.0d0)
5107      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5108                   if (energy_dec.and.wcorr4.gt.0.0d0)
5109      1                 write (iout,'(a6,2i5,0pf7.3)')
5110      2                'ecorr4',i,j,eello4(i,j,i+1,j1,jj,kk)
5111                 if (wcorr5.gt.0.0d0)
5112      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5113                   if (energy_dec.and.wcorr5.gt.0.0d0)
5114      1                 write (iout,'(a6,2i5,0pf7.3)')
5115      2                'ecorr5',i,j,eello5(i,j,i+1,j1,jj,kk)
5116 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5117 cd                write(2,*)'ijkl',i,j,i+1,j1
5118                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5119      &               .or. wturn6.eq.0.0d0))then
5120 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5121                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5122                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5123      1                'ecorr6',i,j,eello6(i,j,i+1,j1,jj,kk)
5124 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5125 cd     &            'ecorr6=',ecorr6
5126 cd                write (iout,'(4e15.5)') sred_geom,
5127 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5128 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5129 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5130                 else if (wturn6.gt.0.0d0
5131      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5132 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5133                   eturn6=eturn6+eello_turn6(i,jj,kk)
5134                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5135      1                 'eturn6',i,j,eello_turn6(i,jj,kk)
5136 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5137                 endif
5138               ENDIF
5139 1111          continue
5140             else if (j1.eq.j) then
5141 C Contacts I-J and I-(J+1) occur simultaneously.
5142 C The system loses extra energy.
5143 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5144             endif
5145           enddo ! kk
5146           do kk=1,num_conti
5147             j1=jcont_hb(kk,i)
5148 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5149 c    &         ' jj=',jj,' kk=',kk
5150             if (j1.eq.j+1) then
5151 C Contacts I-J and (I+1)-J occur simultaneously.
5152 C The system loses extra energy.
5153 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5154             endif ! j1==j+1
5155           enddo ! kk
5156         enddo ! jj
5157       enddo ! i
5158       return
5159       end
5160 c------------------------------------------------------------------------------
5161       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5162       implicit real*8 (a-h,o-z)
5163       include 'DIMENSIONS'
5164       include 'COMMON.IOUNITS'
5165       include 'COMMON.DERIV'
5166       include 'COMMON.INTERACT'
5167       include 'COMMON.CONTACTS'
5168       double precision gx(3),gx1(3)
5169       logical lprn
5170       lprn=.false.
5171       eij=facont_hb(jj,i)
5172       ekl=facont_hb(kk,k)
5173       ees0pij=ees0p(jj,i)
5174       ees0pkl=ees0p(kk,k)
5175       ees0mij=ees0m(jj,i)
5176       ees0mkl=ees0m(kk,k)
5177       ekont=eij*ekl
5178       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5179 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5180 C Following 4 lines for diagnostics.
5181 cd    ees0pkl=0.0D0
5182 cd    ees0pij=1.0D0
5183 cd    ees0mkl=0.0D0
5184 cd    ees0mij=1.0D0
5185 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5186 c    &   ' and',k,l
5187 c     write (iout,*)'Contacts have occurred for peptide groups',
5188 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5189 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5190 C Calculate the multi-body contribution to energy.
5191       ecorr=ecorr+ekont*ees
5192 C Calculate multi-body contributions to the gradient.
5193       do ll=1,3
5194         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5195         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5196      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5197      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5198         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5199      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5200      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5201         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5202         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5203      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5204      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5205         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5206      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5207      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5208       enddo
5209       do m=i+1,j-1
5210         do ll=1,3
5211           gradcorr(ll,m)=gradcorr(ll,m)+
5212      &     ees*ekl*gacont_hbr(ll,jj,i)-
5213      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5214      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5215         enddo
5216       enddo
5217       do m=k+1,l-1
5218         do ll=1,3
5219           gradcorr(ll,m)=gradcorr(ll,m)+
5220      &     ees*eij*gacont_hbr(ll,kk,k)-
5221      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5222      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5223         enddo
5224       enddo
5225       ehbcorr=ekont*ees
5226       return
5227       end
5228 #ifdef MOMENT
5229 C---------------------------------------------------------------------------
5230       subroutine dipole(i,j,jj)
5231       implicit real*8 (a-h,o-z)
5232       include 'DIMENSIONS'
5233       include 'COMMON.IOUNITS'
5234       include 'COMMON.CHAIN'
5235       include 'COMMON.FFIELD'
5236       include 'COMMON.DERIV'
5237       include 'COMMON.INTERACT'
5238       include 'COMMON.CONTACTS'
5239       include 'COMMON.TORSION'
5240       include 'COMMON.VAR'
5241       include 'COMMON.GEO'
5242       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
5243      &  auxmat(2,2)
5244       iti1 = itortyp(itype(i+1))
5245       if (j.lt.nres-1) then
5246         itj1 = itortyp(itype(j+1))
5247       else
5248         itj1=ntortyp+1
5249       endif
5250       do iii=1,2
5251         dipi(iii,1)=Ub2(iii,i)
5252         dipderi(iii)=Ub2der(iii,i)
5253         dipi(iii,2)=b1(iii,iti1)
5254         dipj(iii,1)=Ub2(iii,j)
5255         dipderj(iii)=Ub2der(iii,j)
5256         dipj(iii,2)=b1(iii,itj1)
5257       enddo
5258       kkk=0
5259       do iii=1,2
5260         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
5261         do jjj=1,2
5262           kkk=kkk+1
5263           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5264         enddo
5265       enddo
5266       do kkk=1,5
5267         do lll=1,3
5268           mmm=0
5269           do iii=1,2
5270             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
5271      &        auxvec(1))
5272             do jjj=1,2
5273               mmm=mmm+1
5274               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
5275             enddo
5276           enddo
5277         enddo
5278       enddo
5279       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
5280       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
5281       do iii=1,2
5282         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
5283       enddo
5284       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
5285       do iii=1,2
5286         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
5287       enddo
5288       return
5289       end
5290 #endif
5291 C---------------------------------------------------------------------------
5292       subroutine calc_eello(i,j,k,l,jj,kk)
5293 C
5294 C This subroutine computes matrices and vectors needed to calculate
5295 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
5296 C
5297       implicit real*8 (a-h,o-z)
5298       include 'DIMENSIONS'
5299       include 'COMMON.IOUNITS'
5300       include 'COMMON.CHAIN'
5301       include 'COMMON.DERIV'
5302       include 'COMMON.INTERACT'
5303       include 'COMMON.CONTACTS'
5304       include 'COMMON.TORSION'
5305       include 'COMMON.VAR'
5306       include 'COMMON.GEO'
5307       include 'COMMON.FFIELD'
5308       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
5309      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
5310       logical lprn
5311       common /kutas/ lprn
5312 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
5313 cd     & ' jj=',jj,' kk=',kk
5314 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
5315       do iii=1,2
5316         do jjj=1,2
5317           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
5318           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
5319         enddo
5320       enddo
5321       call transpose2(aa1(1,1),aa1t(1,1))
5322       call transpose2(aa2(1,1),aa2t(1,1))
5323       do kkk=1,5
5324         do lll=1,3
5325           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
5326      &      aa1tder(1,1,lll,kkk))
5327           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
5328      &      aa2tder(1,1,lll,kkk))
5329         enddo
5330       enddo
5331       if (l.eq.j+1) then
5332 C parallel orientation of the two CA-CA-CA frames.
5333         if (i.gt.1) then
5334           iti=itortyp(itype(i))
5335         else
5336           iti=ntortyp+1
5337         endif
5338         itk1=itortyp(itype(k+1))
5339         itj=itortyp(itype(j))
5340         if (l.lt.nres-1) then
5341           itl1=itortyp(itype(l+1))
5342         else
5343           itl1=ntortyp+1
5344         endif
5345 C A1 kernel(j+1) A2T
5346 cd        do iii=1,2
5347 cd          write (iout,'(3f10.5,5x,3f10.5)')
5348 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
5349 cd        enddo
5350         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5351      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
5352      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5353 C Following matrices are needed only for 6-th order cumulants
5354         IF (wcorr6.gt.0.0d0) THEN
5355         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5356      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
5357      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5358         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5359      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
5360      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5361      &   ADtEAderx(1,1,1,1,1,1))
5362         lprn=.false.
5363         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5364      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
5365      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5366      &   ADtEA1derx(1,1,1,1,1,1))
5367         ENDIF
5368 C End 6-th order cumulants
5369 cd        lprn=.false.
5370 cd        if (lprn) then
5371 cd        write (2,*) 'In calc_eello6'
5372 cd        do iii=1,2
5373 cd          write (2,*) 'iii=',iii
5374 cd          do kkk=1,5
5375 cd            write (2,*) 'kkk=',kkk
5376 cd            do jjj=1,2
5377 cd              write (2,'(3(2f10.5),5x)')
5378 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
5379 cd            enddo
5380 cd          enddo
5381 cd        enddo
5382 cd        endif
5383         call transpose2(EUgder(1,1,k),auxmat(1,1))
5384         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5385         call transpose2(EUg(1,1,k),auxmat(1,1))
5386         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5387         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5388         do iii=1,2
5389           do kkk=1,5
5390             do lll=1,3
5391               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5392      &          EAEAderx(1,1,lll,kkk,iii,1))
5393             enddo
5394           enddo
5395         enddo
5396 C A1T kernel(i+1) A2
5397         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5398      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
5399      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5400 C Following matrices are needed only for 6-th order cumulants
5401         IF (wcorr6.gt.0.0d0) THEN
5402         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5403      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
5404      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5405         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5406      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
5407      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5408      &   ADtEAderx(1,1,1,1,1,2))
5409         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
5410      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
5411      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5412      &   ADtEA1derx(1,1,1,1,1,2))
5413         ENDIF
5414 C End 6-th order cumulants
5415         call transpose2(EUgder(1,1,l),auxmat(1,1))
5416         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
5417         call transpose2(EUg(1,1,l),auxmat(1,1))
5418         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5419         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5420         do iii=1,2
5421           do kkk=1,5
5422             do lll=1,3
5423               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5424      &          EAEAderx(1,1,lll,kkk,iii,2))
5425             enddo
5426           enddo
5427         enddo
5428 C AEAb1 and AEAb2
5429 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5430 C They are needed only when the fifth- or the sixth-order cumulants are
5431 C indluded.
5432         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
5433         call transpose2(AEA(1,1,1),auxmat(1,1))
5434         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5435         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5436         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5437         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5438         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5439         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5440         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5441         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5442         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5443         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5444         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5445         call transpose2(AEA(1,1,2),auxmat(1,1))
5446         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
5447         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
5448         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
5449         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5450         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
5451         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
5452         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
5453         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
5454         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
5455         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
5456         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
5457 C Calculate the Cartesian derivatives of the vectors.
5458         do iii=1,2
5459           do kkk=1,5
5460             do lll=1,3
5461               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5462               call matvec2(auxmat(1,1),b1(1,iti),
5463      &          AEAb1derx(1,lll,kkk,iii,1,1))
5464               call matvec2(auxmat(1,1),Ub2(1,i),
5465      &          AEAb2derx(1,lll,kkk,iii,1,1))
5466               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5467      &          AEAb1derx(1,lll,kkk,iii,2,1))
5468               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5469      &          AEAb2derx(1,lll,kkk,iii,2,1))
5470               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5471               call matvec2(auxmat(1,1),b1(1,itj),
5472      &          AEAb1derx(1,lll,kkk,iii,1,2))
5473               call matvec2(auxmat(1,1),Ub2(1,j),
5474      &          AEAb2derx(1,lll,kkk,iii,1,2))
5475               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
5476      &          AEAb1derx(1,lll,kkk,iii,2,2))
5477               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
5478      &          AEAb2derx(1,lll,kkk,iii,2,2))
5479             enddo
5480           enddo
5481         enddo
5482         ENDIF
5483 C End vectors
5484       else
5485 C Antiparallel orientation of the two CA-CA-CA frames.
5486         if (i.gt.1) then
5487           iti=itortyp(itype(i))
5488         else
5489           iti=ntortyp+1
5490         endif
5491         itk1=itortyp(itype(k+1))
5492         itl=itortyp(itype(l))
5493         itj=itortyp(itype(j))
5494         if (j.lt.nres-1) then
5495           itj1=itortyp(itype(j+1))
5496         else
5497           itj1=ntortyp+1
5498         endif
5499 C A2 kernel(j-1)T A1T
5500         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5501      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
5502      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
5503 C Following matrices are needed only for 6-th order cumulants
5504         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5505      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5506         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5507      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
5508      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
5509         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5510      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
5511      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
5512      &   ADtEAderx(1,1,1,1,1,1))
5513         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
5514      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
5515      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
5516      &   ADtEA1derx(1,1,1,1,1,1))
5517         ENDIF
5518 C End 6-th order cumulants
5519         call transpose2(EUgder(1,1,k),auxmat(1,1))
5520         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
5521         call transpose2(EUg(1,1,k),auxmat(1,1))
5522         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
5523         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
5524         do iii=1,2
5525           do kkk=1,5
5526             do lll=1,3
5527               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5528      &          EAEAderx(1,1,lll,kkk,iii,1))
5529             enddo
5530           enddo
5531         enddo
5532 C A2T kernel(i+1)T A1
5533         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5534      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
5535      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
5536 C Following matrices are needed only for 6-th order cumulants
5537         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
5538      &     j.eq.i+4 .and. l.eq.i+3)) THEN
5539         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5540      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
5541      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
5542         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5543      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
5544      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
5545      &   ADtEAderx(1,1,1,1,1,2))
5546         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
5547      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
5548      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
5549      &   ADtEA1derx(1,1,1,1,1,2))
5550         ENDIF
5551 C End 6-th order cumulants
5552         call transpose2(EUgder(1,1,j),auxmat(1,1))
5553         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
5554         call transpose2(EUg(1,1,j),auxmat(1,1))
5555         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
5556         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
5557         do iii=1,2
5558           do kkk=1,5
5559             do lll=1,3
5560               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
5561      &          EAEAderx(1,1,lll,kkk,iii,2))
5562             enddo
5563           enddo
5564         enddo
5565 C AEAb1 and AEAb2
5566 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
5567 C They are needed only when the fifth- or the sixth-order cumulants are
5568 C indluded.
5569         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
5570      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
5571         call transpose2(AEA(1,1,1),auxmat(1,1))
5572         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
5573         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
5574         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
5575         call transpose2(AEAderg(1,1,1),auxmat(1,1))
5576         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
5577         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
5578         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
5579         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
5580         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
5581         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
5582         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
5583         call transpose2(AEA(1,1,2),auxmat(1,1))
5584         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
5585         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
5586         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
5587         call transpose2(AEAderg(1,1,2),auxmat(1,1))
5588         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
5589         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
5590         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
5591         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
5592         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
5593         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
5594         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
5595 C Calculate the Cartesian derivatives of the vectors.
5596         do iii=1,2
5597           do kkk=1,5
5598             do lll=1,3
5599               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
5600               call matvec2(auxmat(1,1),b1(1,iti),
5601      &          AEAb1derx(1,lll,kkk,iii,1,1))
5602               call matvec2(auxmat(1,1),Ub2(1,i),
5603      &          AEAb2derx(1,lll,kkk,iii,1,1))
5604               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
5605      &          AEAb1derx(1,lll,kkk,iii,2,1))
5606               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
5607      &          AEAb2derx(1,lll,kkk,iii,2,1))
5608               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
5609               call matvec2(auxmat(1,1),b1(1,itl),
5610      &          AEAb1derx(1,lll,kkk,iii,1,2))
5611               call matvec2(auxmat(1,1),Ub2(1,l),
5612      &          AEAb2derx(1,lll,kkk,iii,1,2))
5613               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
5614      &          AEAb1derx(1,lll,kkk,iii,2,2))
5615               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
5616      &          AEAb2derx(1,lll,kkk,iii,2,2))
5617             enddo
5618           enddo
5619         enddo
5620         ENDIF
5621 C End vectors
5622       endif
5623       return
5624       end
5625 C---------------------------------------------------------------------------
5626       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
5627      &  KK,KKderg,AKA,AKAderg,AKAderx)
5628       implicit none
5629       integer nderg
5630       logical transp
5631       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
5632      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
5633      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
5634       integer iii,kkk,lll
5635       integer jjj,mmm
5636       logical lprn
5637       common /kutas/ lprn
5638       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
5639       do iii=1,nderg
5640         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
5641      &    AKAderg(1,1,iii))
5642       enddo
5643 cd      if (lprn) write (2,*) 'In kernel'
5644       do kkk=1,5
5645 cd        if (lprn) write (2,*) 'kkk=',kkk
5646         do lll=1,3
5647           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
5648      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
5649 cd          if (lprn) then
5650 cd            write (2,*) 'lll=',lll
5651 cd            write (2,*) 'iii=1'
5652 cd            do jjj=1,2
5653 cd              write (2,'(3(2f10.5),5x)')
5654 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
5655 cd            enddo
5656 cd          endif
5657           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
5658      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
5659 cd          if (lprn) then
5660 cd            write (2,*) 'lll=',lll
5661 cd            write (2,*) 'iii=2'
5662 cd            do jjj=1,2
5663 cd              write (2,'(3(2f10.5),5x)')
5664 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
5665 cd            enddo
5666 cd          endif
5667         enddo
5668       enddo
5669       return
5670       end
5671 C---------------------------------------------------------------------------
5672       double precision function eello4(i,j,k,l,jj,kk)
5673       implicit real*8 (a-h,o-z)
5674       include 'DIMENSIONS'
5675       include 'COMMON.IOUNITS'
5676       include 'COMMON.CHAIN'
5677       include 'COMMON.DERIV'
5678       include 'COMMON.INTERACT'
5679       include 'COMMON.CONTACTS'
5680       include 'COMMON.TORSION'
5681       include 'COMMON.VAR'
5682       include 'COMMON.GEO'
5683       double precision pizda(2,2),ggg1(3),ggg2(3)
5684 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
5685 cd        eello4=0.0d0
5686 cd        return
5687 cd      endif
5688 cd      print *,'eello4:',i,j,k,l,jj,kk
5689 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
5690 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
5691 cold      eij=facont_hb(jj,i)
5692 cold      ekl=facont_hb(kk,k)
5693 cold      ekont=eij*ekl
5694       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
5695 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
5696       gcorr_loc(k-1)=gcorr_loc(k-1)
5697      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
5698       if (l.eq.j+1) then
5699         gcorr_loc(l-1)=gcorr_loc(l-1)
5700      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5701       else
5702         gcorr_loc(j-1)=gcorr_loc(j-1)
5703      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
5704       endif
5705       do iii=1,2
5706         do kkk=1,5
5707           do lll=1,3
5708             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
5709      &                        -EAEAderx(2,2,lll,kkk,iii,1)
5710 cd            derx(lll,kkk,iii)=0.0d0
5711           enddo
5712         enddo
5713       enddo
5714 cd      gcorr_loc(l-1)=0.0d0
5715 cd      gcorr_loc(j-1)=0.0d0
5716 cd      gcorr_loc(k-1)=0.0d0
5717 cd      eel4=1.0d0
5718 cd      write (iout,*)'Contacts have occurred for peptide groups',
5719 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
5720 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
5721       if (j.lt.nres-1) then
5722         j1=j+1
5723         j2=j-1
5724       else
5725         j1=j-1
5726         j2=j-2
5727       endif
5728       if (l.lt.nres-1) then
5729         l1=l+1
5730         l2=l-1
5731       else
5732         l1=l-1
5733         l2=l-2
5734       endif
5735       do ll=1,3
5736 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
5737         ggg1(ll)=eel4*g_contij(ll,1)
5738         ggg2(ll)=eel4*g_contij(ll,2)
5739         ghalf=0.5d0*ggg1(ll)
5740 cd        ghalf=0.0d0
5741         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
5742         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
5743         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
5744         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
5745 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
5746         ghalf=0.5d0*ggg2(ll)
5747 cd        ghalf=0.0d0
5748         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
5749         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
5750         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
5751         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
5752       enddo
5753 cd      goto 1112
5754       do m=i+1,j-1
5755         do ll=1,3
5756 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
5757           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
5758         enddo
5759       enddo
5760       do m=k+1,l-1
5761         do ll=1,3
5762 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
5763           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
5764         enddo
5765       enddo
5766 1112  continue
5767       do m=i+2,j2
5768         do ll=1,3
5769           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
5770         enddo
5771       enddo
5772       do m=k+2,l2
5773         do ll=1,3
5774           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
5775         enddo
5776       enddo
5777 cd      do iii=1,nres-3
5778 cd        write (2,*) iii,gcorr_loc(iii)
5779 cd      enddo
5780       eello4=ekont*eel4
5781 cd      write (2,*) 'ekont',ekont
5782 cd      write (iout,*) 'eello4',ekont*eel4
5783       return
5784       end
5785 C---------------------------------------------------------------------------
5786       double precision function eello5(i,j,k,l,jj,kk)
5787       implicit real*8 (a-h,o-z)
5788       include 'DIMENSIONS'
5789       include 'COMMON.IOUNITS'
5790       include 'COMMON.CHAIN'
5791       include 'COMMON.DERIV'
5792       include 'COMMON.INTERACT'
5793       include 'COMMON.CONTACTS'
5794       include 'COMMON.TORSION'
5795       include 'COMMON.VAR'
5796       include 'COMMON.GEO'
5797       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
5798       double precision ggg1(3),ggg2(3)
5799 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5800 C                                                                              C
5801 C                            Parallel chains                                   C
5802 C                                                                              C
5803 C          o             o                   o             o                   C
5804 C         /l\           / \             \   / \           / \   /              C
5805 C        /   \         /   \             \ /   \         /   \ /               C
5806 C       j| o |l1       | o |              o| o |         | o |o                C
5807 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5808 C      \i/   \         /   \ /             /   \         /   \                 C
5809 C       o    k1             o                                                  C
5810 C         (I)          (II)                (III)          (IV)                 C
5811 C                                                                              C
5812 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5813 C                                                                              C
5814 C                            Antiparallel chains                               C
5815 C                                                                              C
5816 C          o             o                   o             o                   C
5817 C         /j\           / \             \   / \           / \   /              C
5818 C        /   \         /   \             \ /   \         /   \ /               C
5819 C      j1| o |l        | o |              o| o |         | o |o                C
5820 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
5821 C      \i/   \         /   \ /             /   \         /   \                 C
5822 C       o     k1            o                                                  C
5823 C         (I)          (II)                (III)          (IV)                 C
5824 C                                                                              C
5825 C      eello5_1        eello5_2            eello5_3       eello5_4             C
5826 C                                                                              C
5827 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
5828 C                                                                              C
5829 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5830 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
5831 cd        eello5=0.0d0
5832 cd        return
5833 cd      endif
5834 cd      write (iout,*)
5835 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
5836 cd     &   ' and',k,l
5837       itk=itortyp(itype(k))
5838       itl=itortyp(itype(l))
5839       itj=itortyp(itype(j))
5840       eello5_1=0.0d0
5841       eello5_2=0.0d0
5842       eello5_3=0.0d0
5843       eello5_4=0.0d0
5844 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
5845 cd     &   eel5_3_num,eel5_4_num)
5846       do iii=1,2
5847         do kkk=1,5
5848           do lll=1,3
5849             derx(lll,kkk,iii)=0.0d0
5850           enddo
5851         enddo
5852       enddo
5853 cd      eij=facont_hb(jj,i)
5854 cd      ekl=facont_hb(kk,k)
5855 cd      ekont=eij*ekl
5856 cd      write (iout,*)'Contacts have occurred for peptide groups',
5857 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
5858 cd      goto 1111
5859 C Contribution from the graph I.
5860 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
5861 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
5862       call transpose2(EUg(1,1,k),auxmat(1,1))
5863       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
5864       vv(1)=pizda(1,1)-pizda(2,2)
5865       vv(2)=pizda(1,2)+pizda(2,1)
5866       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
5867      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
5868 C Explicit gradient in virtual-dihedral angles.
5869       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
5870      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
5871      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
5872       call transpose2(EUgder(1,1,k),auxmat1(1,1))
5873       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
5874       vv(1)=pizda(1,1)-pizda(2,2)
5875       vv(2)=pizda(1,2)+pizda(2,1)
5876       g_corr5_loc(k-1)=g_corr5_loc(k-1)
5877      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
5878      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5879       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
5880       vv(1)=pizda(1,1)-pizda(2,2)
5881       vv(2)=pizda(1,2)+pizda(2,1)
5882       if (l.eq.j+1) then
5883         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
5884      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
5885      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5886       else
5887         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
5888      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
5889      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
5890       endif
5891 C Cartesian gradient
5892       do iii=1,2
5893         do kkk=1,5
5894           do lll=1,3
5895             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
5896      &        pizda(1,1))
5897             vv(1)=pizda(1,1)-pizda(2,2)
5898             vv(2)=pizda(1,2)+pizda(2,1)
5899             derx(lll,kkk,iii)=derx(lll,kkk,iii)
5900      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
5901      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
5902           enddo
5903         enddo
5904       enddo
5905 c      goto 1112
5906 c1111  continue
5907 C Contribution from graph II
5908       call transpose2(EE(1,1,itk),auxmat(1,1))
5909       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
5910       vv(1)=pizda(1,1)+pizda(2,2)
5911       vv(2)=pizda(2,1)-pizda(1,2)
5912       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
5913      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
5914 C Explicit gradient in virtual-dihedral angles.
5915       g_corr5_loc(k-1)=g_corr5_loc(k-1)
5916      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
5917       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
5918       vv(1)=pizda(1,1)+pizda(2,2)
5919       vv(2)=pizda(2,1)-pizda(1,2)
5920       if (l.eq.j+1) then
5921         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5922      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
5923      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
5924       else
5925         g_corr5_loc(j-1)=g_corr5_loc(j-1)
5926      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
5927      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
5928       endif
5929 C Cartesian gradient
5930       do iii=1,2
5931         do kkk=1,5
5932           do lll=1,3
5933             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
5934      &        pizda(1,1))
5935             vv(1)=pizda(1,1)+pizda(2,2)
5936             vv(2)=pizda(2,1)-pizda(1,2)
5937             derx(lll,kkk,iii)=derx(lll,kkk,iii)
5938      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
5939      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
5940           enddo
5941         enddo
5942       enddo
5943 cd      goto 1112
5944 cd1111  continue
5945       if (l.eq.j+1) then
5946 cd        goto 1110
5947 C Parallel orientation
5948 C Contribution from graph III
5949         call transpose2(EUg(1,1,l),auxmat(1,1))
5950         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
5951         vv(1)=pizda(1,1)-pizda(2,2)
5952         vv(2)=pizda(1,2)+pizda(2,1)
5953         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
5954      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
5955 C Explicit gradient in virtual-dihedral angles.
5956         g_corr5_loc(j-1)=g_corr5_loc(j-1)
5957      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
5958      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
5959         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
5960         vv(1)=pizda(1,1)-pizda(2,2)
5961         vv(2)=pizda(1,2)+pizda(2,1)
5962         g_corr5_loc(k-1)=g_corr5_loc(k-1)
5963      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
5964      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
5965         call transpose2(EUgder(1,1,l),auxmat1(1,1))
5966         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
5967         vv(1)=pizda(1,1)-pizda(2,2)
5968         vv(2)=pizda(1,2)+pizda(2,1)
5969         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5970      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
5971      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
5972 C Cartesian gradient
5973         do iii=1,2
5974           do kkk=1,5
5975             do lll=1,3
5976               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
5977      &          pizda(1,1))
5978               vv(1)=pizda(1,1)-pizda(2,2)
5979               vv(2)=pizda(1,2)+pizda(2,1)
5980               derx(lll,kkk,iii)=derx(lll,kkk,iii)
5981      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
5982      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
5983             enddo
5984           enddo
5985         enddo
5986 cd        goto 1112
5987 C Contribution from graph IV
5988 cd1110    continue
5989         call transpose2(EE(1,1,itl),auxmat(1,1))
5990         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
5991         vv(1)=pizda(1,1)+pizda(2,2)
5992         vv(2)=pizda(2,1)-pizda(1,2)
5993         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
5994      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
5995 C Explicit gradient in virtual-dihedral angles.
5996         g_corr5_loc(l-1)=g_corr5_loc(l-1)
5997      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
5998         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
5999         vv(1)=pizda(1,1)+pizda(2,2)
6000         vv(2)=pizda(2,1)-pizda(1,2)
6001         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6002      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6003      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6004 C Cartesian gradient
6005         do iii=1,2
6006           do kkk=1,5
6007             do lll=1,3
6008               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6009      &          pizda(1,1))
6010               vv(1)=pizda(1,1)+pizda(2,2)
6011               vv(2)=pizda(2,1)-pizda(1,2)
6012               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6013      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6014      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6015             enddo
6016           enddo
6017         enddo
6018       else
6019 C Antiparallel orientation
6020 C Contribution from graph III
6021 c        goto 1110
6022         call transpose2(EUg(1,1,j),auxmat(1,1))
6023         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6024         vv(1)=pizda(1,1)-pizda(2,2)
6025         vv(2)=pizda(1,2)+pizda(2,1)
6026         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6027      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6028 C Explicit gradient in virtual-dihedral angles.
6029         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6030      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6031      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6032         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6033         vv(1)=pizda(1,1)-pizda(2,2)
6034         vv(2)=pizda(1,2)+pizda(2,1)
6035         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6036      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6037      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6038         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6039         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6040         vv(1)=pizda(1,1)-pizda(2,2)
6041         vv(2)=pizda(1,2)+pizda(2,1)
6042         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6043      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6044      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6045 C Cartesian gradient
6046         do iii=1,2
6047           do kkk=1,5
6048             do lll=1,3
6049               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6050      &          pizda(1,1))
6051               vv(1)=pizda(1,1)-pizda(2,2)
6052               vv(2)=pizda(1,2)+pizda(2,1)
6053               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6054      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6055      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6056             enddo
6057           enddo
6058         enddo
6059 cd        goto 1112
6060 C Contribution from graph IV
6061 1110    continue
6062         call transpose2(EE(1,1,itj),auxmat(1,1))
6063         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6064         vv(1)=pizda(1,1)+pizda(2,2)
6065         vv(2)=pizda(2,1)-pizda(1,2)
6066         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6067      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6068 C Explicit gradient in virtual-dihedral angles.
6069         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6070      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6071         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6072         vv(1)=pizda(1,1)+pizda(2,2)
6073         vv(2)=pizda(2,1)-pizda(1,2)
6074         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6075      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6076      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6077 C Cartesian gradient
6078         do iii=1,2
6079           do kkk=1,5
6080             do lll=1,3
6081               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6082      &          pizda(1,1))
6083               vv(1)=pizda(1,1)+pizda(2,2)
6084               vv(2)=pizda(2,1)-pizda(1,2)
6085               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6086      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6087      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6088             enddo
6089           enddo
6090         enddo
6091       endif
6092 1112  continue
6093       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6094 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6095 cd        write (2,*) 'ijkl',i,j,k,l
6096 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6097 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6098 cd      endif
6099 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6100 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6101 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6102 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6103       if (j.lt.nres-1) then
6104         j1=j+1
6105         j2=j-1
6106       else
6107         j1=j-1
6108         j2=j-2
6109       endif
6110       if (l.lt.nres-1) then
6111         l1=l+1
6112         l2=l-1
6113       else
6114         l1=l-1
6115         l2=l-2
6116       endif
6117 cd      eij=1.0d0
6118 cd      ekl=1.0d0
6119 cd      ekont=1.0d0
6120 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6121       do ll=1,3
6122         ggg1(ll)=eel5*g_contij(ll,1)
6123         ggg2(ll)=eel5*g_contij(ll,2)
6124 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6125         ghalf=0.5d0*ggg1(ll)
6126 cd        ghalf=0.0d0
6127         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6128         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6129         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6130         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6131 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6132         ghalf=0.5d0*ggg2(ll)
6133 cd        ghalf=0.0d0
6134         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6135         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6136         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6137         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6138       enddo
6139 cd      goto 1112
6140       do m=i+1,j-1
6141         do ll=1,3
6142 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6143           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6144         enddo
6145       enddo
6146       do m=k+1,l-1
6147         do ll=1,3
6148 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6149           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6150         enddo
6151       enddo
6152 c1112  continue
6153       do m=i+2,j2
6154         do ll=1,3
6155           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6156         enddo
6157       enddo
6158       do m=k+2,l2
6159         do ll=1,3
6160           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6161         enddo
6162       enddo
6163 cd      do iii=1,nres-3
6164 cd        write (2,*) iii,g_corr5_loc(iii)
6165 cd      enddo
6166       eello5=ekont*eel5
6167 cd      write (2,*) 'ekont',ekont
6168 cd      write (iout,*) 'eello5',ekont*eel5
6169       return
6170       end
6171 c--------------------------------------------------------------------------
6172       double precision function eello6(i,j,k,l,jj,kk)
6173       implicit real*8 (a-h,o-z)
6174       include 'DIMENSIONS'
6175       include 'COMMON.IOUNITS'
6176       include 'COMMON.CHAIN'
6177       include 'COMMON.DERIV'
6178       include 'COMMON.INTERACT'
6179       include 'COMMON.CONTACTS'
6180       include 'COMMON.TORSION'
6181       include 'COMMON.VAR'
6182       include 'COMMON.GEO'
6183       include 'COMMON.FFIELD'
6184       double precision ggg1(3),ggg2(3)
6185 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6186 cd        eello6=0.0d0
6187 cd        return
6188 cd      endif
6189 cd      write (iout,*)
6190 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6191 cd     &   ' and',k,l
6192       eello6_1=0.0d0
6193       eello6_2=0.0d0
6194       eello6_3=0.0d0
6195       eello6_4=0.0d0
6196       eello6_5=0.0d0
6197       eello6_6=0.0d0
6198 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6199 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6200       do iii=1,2
6201         do kkk=1,5
6202           do lll=1,3
6203             derx(lll,kkk,iii)=0.0d0
6204           enddo
6205         enddo
6206       enddo
6207 cd      eij=facont_hb(jj,i)
6208 cd      ekl=facont_hb(kk,k)
6209 cd      ekont=eij*ekl
6210 cd      eij=1.0d0
6211 cd      ekl=1.0d0
6212 cd      ekont=1.0d0
6213       if (l.eq.j+1) then
6214         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6215         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6216         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6217         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6218         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6219         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6220       else
6221         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6222         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6223         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6224         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6225         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
6226           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
6227         else
6228           eello6_5=0.0d0
6229         endif
6230         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
6231       endif
6232 C If turn contributions are considered, they will be handled separately.
6233       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
6234 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
6235 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
6236 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
6237 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
6238 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
6239 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
6240 cd      goto 1112
6241       if (j.lt.nres-1) then
6242         j1=j+1
6243         j2=j-1
6244       else
6245         j1=j-1
6246         j2=j-2
6247       endif
6248       if (l.lt.nres-1) then
6249         l1=l+1
6250         l2=l-1
6251       else
6252         l1=l-1
6253         l2=l-2
6254       endif
6255       do ll=1,3
6256         ggg1(ll)=eel6*g_contij(ll,1)
6257         ggg2(ll)=eel6*g_contij(ll,2)
6258 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
6259         ghalf=0.5d0*ggg1(ll)
6260 cd        ghalf=0.0d0
6261         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
6262         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
6263         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
6264         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
6265         ghalf=0.5d0*ggg2(ll)
6266 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
6267 cd        ghalf=0.0d0
6268         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
6269         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
6270         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
6271         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
6272       enddo
6273 cd      goto 1112
6274       do m=i+1,j-1
6275         do ll=1,3
6276 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
6277           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
6278         enddo
6279       enddo
6280       do m=k+1,l-1
6281         do ll=1,3
6282 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
6283           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
6284         enddo
6285       enddo
6286 1112  continue
6287       do m=i+2,j2
6288         do ll=1,3
6289           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
6290         enddo
6291       enddo
6292       do m=k+2,l2
6293         do ll=1,3
6294           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
6295         enddo
6296       enddo
6297 cd      do iii=1,nres-3
6298 cd        write (2,*) iii,g_corr6_loc(iii)
6299 cd      enddo
6300       eello6=ekont*eel6
6301 cd      write (2,*) 'ekont',ekont
6302 cd      write (iout,*) 'eello6',ekont*eel6
6303       return
6304       end
6305 c--------------------------------------------------------------------------
6306       double precision function eello6_graph1(i,j,k,l,imat,swap)
6307       implicit real*8 (a-h,o-z)
6308       include 'DIMENSIONS'
6309       include 'COMMON.IOUNITS'
6310       include 'COMMON.CHAIN'
6311       include 'COMMON.DERIV'
6312       include 'COMMON.INTERACT'
6313       include 'COMMON.CONTACTS'
6314       include 'COMMON.TORSION'
6315       include 'COMMON.VAR'
6316       include 'COMMON.GEO'
6317       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
6318       logical swap
6319       logical lprn
6320       common /kutas/ lprn
6321 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6322 C
6323 C      Parallel       Antiparallel
6324 C
6325 C          o             o
6326 C         /l\           /j\
6327 C        /   \         /   \
6328 C       /| o |         | o |\
6329 C     \ j|/k\|  /   \  |/k\|l /
6330 C      \ /   \ /     \ /   \ /
6331 C       o     o       o     o
6332 C       i             i
6333 C
6334 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6335       itk=itortyp(itype(k))
6336       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
6337       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
6338       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
6339       call transpose2(EUgC(1,1,k),auxmat(1,1))
6340       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6341       vv1(1)=pizda1(1,1)-pizda1(2,2)
6342       vv1(2)=pizda1(1,2)+pizda1(2,1)
6343       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6344       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
6345       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
6346       s5=scalar2(vv(1),Dtobr2(1,i))
6347 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
6348       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
6349       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
6350      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
6351      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
6352      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
6353      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
6354      & +scalar2(vv(1),Dtobr2der(1,i)))
6355       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
6356       vv1(1)=pizda1(1,1)-pizda1(2,2)
6357       vv1(2)=pizda1(1,2)+pizda1(2,1)
6358       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
6359       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
6360       if (l.eq.j+1) then
6361         g_corr6_loc(l-1)=g_corr6_loc(l-1)
6362      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6363      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6364      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6365      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6366       else
6367         g_corr6_loc(j-1)=g_corr6_loc(j-1)
6368      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
6369      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
6370      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
6371      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
6372       endif
6373       call transpose2(EUgCder(1,1,k),auxmat(1,1))
6374       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
6375       vv1(1)=pizda1(1,1)-pizda1(2,2)
6376       vv1(2)=pizda1(1,2)+pizda1(2,1)
6377       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
6378      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
6379      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
6380      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
6381       do iii=1,2
6382         if (swap) then
6383           ind=3-iii
6384         else
6385           ind=iii
6386         endif
6387         do kkk=1,5
6388           do lll=1,3
6389             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
6390             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
6391             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
6392             call transpose2(EUgC(1,1,k),auxmat(1,1))
6393             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6394      &        pizda1(1,1))
6395             vv1(1)=pizda1(1,1)-pizda1(2,2)
6396             vv1(2)=pizda1(1,2)+pizda1(2,1)
6397             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
6398             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
6399      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
6400             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
6401      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
6402             s5=scalar2(vv(1),Dtobr2(1,i))
6403             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
6404           enddo
6405         enddo
6406       enddo
6407       return
6408       end
6409 c----------------------------------------------------------------------------
6410       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
6411       implicit real*8 (a-h,o-z)
6412       include 'DIMENSIONS'
6413       include 'COMMON.IOUNITS'
6414       include 'COMMON.CHAIN'
6415       include 'COMMON.DERIV'
6416       include 'COMMON.INTERACT'
6417       include 'COMMON.CONTACTS'
6418       include 'COMMON.TORSION'
6419       include 'COMMON.VAR'
6420       include 'COMMON.GEO'
6421       logical swap
6422       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6423      & auxvec1(2),auxvec2(1),auxmat1(2,2)
6424       logical lprn
6425       common /kutas/ lprn
6426 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6427 C
6428 C      Parallel       Antiparallel
6429 C
6430 C          o             o
6431 C     \   /l\           /j\   /
6432 C      \ /   \         /   \ /
6433 C       o| o |         | o |o
6434 C     \ j|/k\|      \  |/k\|l
6435 C      \ /   \       \ /   \
6436 C       o             o
6437 C       i             i
6438 C
6439 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6440 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
6441 C AL 7/4/01 s1 would occur in the sixth-order moment,
6442 C           but not in a cluster cumulant
6443 #ifdef MOMENT
6444       s1=dip(1,jj,i)*dip(1,kk,k)
6445 #endif
6446       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
6447       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6448       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
6449       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
6450       call transpose2(EUg(1,1,k),auxmat(1,1))
6451       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
6452       vv(1)=pizda(1,1)-pizda(2,2)
6453       vv(2)=pizda(1,2)+pizda(2,1)
6454       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6455 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6456 #ifdef MOMENT
6457       eello6_graph2=-(s1+s2+s3+s4)
6458 #else
6459       eello6_graph2=-(s2+s3+s4)
6460 #endif
6461 c      eello6_graph2=-s3
6462 C Derivatives in gamma(i-1)
6463       if (i.gt.1) then
6464 #ifdef MOMENT
6465         s1=dipderg(1,jj,i)*dip(1,kk,k)
6466 #endif
6467         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6468         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
6469         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6470         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6471 #ifdef MOMENT
6472         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6473 #else
6474         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6475 #endif
6476 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
6477       endif
6478 C Derivatives in gamma(k-1)
6479 #ifdef MOMENT
6480       s1=dip(1,jj,i)*dipderg(1,kk,k)
6481 #endif
6482       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
6483       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6484       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
6485       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6486       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6487       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
6488       vv(1)=pizda(1,1)-pizda(2,2)
6489       vv(2)=pizda(1,2)+pizda(2,1)
6490       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6491 #ifdef MOMENT
6492       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6493 #else
6494       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6495 #endif
6496 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
6497 C Derivatives in gamma(j-1) or gamma(l-1)
6498       if (j.gt.1) then
6499 #ifdef MOMENT
6500         s1=dipderg(3,jj,i)*dip(1,kk,k)
6501 #endif
6502         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
6503         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6504         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
6505         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
6506         vv(1)=pizda(1,1)-pizda(2,2)
6507         vv(2)=pizda(1,2)+pizda(2,1)
6508         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6509 #ifdef MOMENT
6510         if (swap) then
6511           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6512         else
6513           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6514         endif
6515 #endif
6516         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
6517 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
6518       endif
6519 C Derivatives in gamma(l-1) or gamma(j-1)
6520       if (l.gt.1) then
6521 #ifdef MOMENT
6522         s1=dip(1,jj,i)*dipderg(3,kk,k)
6523 #endif
6524         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
6525         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
6526         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
6527         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
6528         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
6529         vv(1)=pizda(1,1)-pizda(2,2)
6530         vv(2)=pizda(1,2)+pizda(2,1)
6531         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6532 #ifdef MOMENT
6533         if (swap) then
6534           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
6535         else
6536           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
6537         endif
6538 #endif
6539         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
6540 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
6541       endif
6542 C Cartesian derivatives.
6543       if (lprn) then
6544         write (2,*) 'In eello6_graph2'
6545         do iii=1,2
6546           write (2,*) 'iii=',iii
6547           do kkk=1,5
6548             write (2,*) 'kkk=',kkk
6549             do jjj=1,2
6550               write (2,'(3(2f10.5),5x)')
6551      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6552             enddo
6553           enddo
6554         enddo
6555       endif
6556       do iii=1,2
6557         do kkk=1,5
6558           do lll=1,3
6559 #ifdef MOMENT
6560             if (iii.eq.1) then
6561               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
6562             else
6563               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
6564             endif
6565 #endif
6566             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
6567      &        auxvec(1))
6568             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
6569             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
6570      &        auxvec(1))
6571             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
6572             call transpose2(EUg(1,1,k),auxmat(1,1))
6573             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
6574      &        pizda(1,1))
6575             vv(1)=pizda(1,1)-pizda(2,2)
6576             vv(2)=pizda(1,2)+pizda(2,1)
6577             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
6578 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
6579 #ifdef MOMENT
6580             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6581 #else
6582             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6583 #endif
6584             if (swap) then
6585               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6586             else
6587               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6588             endif
6589           enddo
6590         enddo
6591       enddo
6592       return
6593       end
6594 c----------------------------------------------------------------------------
6595       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
6596       implicit real*8 (a-h,o-z)
6597       include 'DIMENSIONS'
6598       include 'COMMON.IOUNITS'
6599       include 'COMMON.CHAIN'
6600       include 'COMMON.DERIV'
6601       include 'COMMON.INTERACT'
6602       include 'COMMON.CONTACTS'
6603       include 'COMMON.TORSION'
6604       include 'COMMON.VAR'
6605       include 'COMMON.GEO'
6606       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
6607       logical swap
6608 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6609 C
6610 C      Parallel       Antiparallel
6611 C
6612 C          o             o
6613 C         /l\   /   \   /j\
6614 C        /   \ /     \ /   \
6615 C       /| o |o       o| o |\
6616 C       j|/k\|  /      |/k\|l /
6617 C        /   \ /       /   \ /
6618 C       /     o       /     o
6619 C       i             i
6620 C
6621 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6622 C
6623 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6624 C           energy moment and not to the cluster cumulant.
6625       iti=itortyp(itype(i))
6626       if (j.lt.nres-1) then
6627         itj1=itortyp(itype(j+1))
6628       else
6629         itj1=ntortyp+1
6630       endif
6631       itk=itortyp(itype(k))
6632       itk1=itortyp(itype(k+1))
6633       if (l.lt.nres-1) then
6634         itl1=itortyp(itype(l+1))
6635       else
6636         itl1=ntortyp+1
6637       endif
6638 #ifdef MOMENT
6639       s1=dip(4,jj,i)*dip(4,kk,k)
6640 #endif
6641       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
6642       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6643       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
6644       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6645       call transpose2(EE(1,1,itk),auxmat(1,1))
6646       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
6647       vv(1)=pizda(1,1)+pizda(2,2)
6648       vv(2)=pizda(2,1)-pizda(1,2)
6649       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6650 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6651 #ifdef MOMENT
6652       eello6_graph3=-(s1+s2+s3+s4)
6653 #else
6654       eello6_graph3=-(s2+s3+s4)
6655 #endif
6656 c      eello6_graph3=-s4
6657 C Derivatives in gamma(k-1)
6658       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
6659       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6660       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
6661       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
6662 C Derivatives in gamma(l-1)
6663       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
6664       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6665       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
6666       vv(1)=pizda(1,1)+pizda(2,2)
6667       vv(2)=pizda(2,1)-pizda(1,2)
6668       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6669       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6670 C Cartesian derivatives.
6671       do iii=1,2
6672         do kkk=1,5
6673           do lll=1,3
6674 #ifdef MOMENT
6675             if (iii.eq.1) then
6676               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
6677             else
6678               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
6679             endif
6680 #endif
6681             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6682      &        auxvec(1))
6683             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
6684             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6685      &        auxvec(1))
6686             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
6687             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
6688      &        pizda(1,1))
6689             vv(1)=pizda(1,1)+pizda(2,2)
6690             vv(2)=pizda(2,1)-pizda(1,2)
6691             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
6692 #ifdef MOMENT
6693             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6694 #else
6695             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6696 #endif
6697             if (swap) then
6698               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6699             else
6700               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6701             endif
6702 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
6703           enddo
6704         enddo
6705       enddo
6706       return
6707       end
6708 c----------------------------------------------------------------------------
6709       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
6710       implicit real*8 (a-h,o-z)
6711       include 'DIMENSIONS'
6712       include 'COMMON.IOUNITS'
6713       include 'COMMON.CHAIN'
6714       include 'COMMON.DERIV'
6715       include 'COMMON.INTERACT'
6716       include 'COMMON.CONTACTS'
6717       include 'COMMON.TORSION'
6718       include 'COMMON.VAR'
6719       include 'COMMON.GEO'
6720       include 'COMMON.FFIELD'
6721       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
6722      & auxvec1(2),auxmat1(2,2)
6723       logical swap
6724 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6725 C
6726 C      Parallel       Antiparallel
6727 C
6728 C          o             o
6729 C         /l\   /   \   /j\
6730 C        /   \ /     \ /   \
6731 C       /| o |o       o| o |\
6732 C     \ j|/k\|      \  |/k\|l
6733 C      \ /   \       \ /   \
6734 C       o     \       o     \
6735 C       i             i
6736 C
6737 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6738 C
6739 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
6740 C           energy moment and not to the cluster cumulant.
6741 cd      write (2,*) 'eello_graph4: wturn6',wturn6
6742       iti=itortyp(itype(i))
6743       itj=itortyp(itype(j))
6744       if (j.lt.nres-1) then
6745         itj1=itortyp(itype(j+1))
6746       else
6747         itj1=ntortyp+1
6748       endif
6749       itk=itortyp(itype(k))
6750       if (k.lt.nres-1) then
6751         itk1=itortyp(itype(k+1))
6752       else
6753         itk1=ntortyp+1
6754       endif
6755       itl=itortyp(itype(l))
6756       if (l.lt.nres-1) then
6757         itl1=itortyp(itype(l+1))
6758       else
6759         itl1=ntortyp+1
6760       endif
6761 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
6762 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
6763 cd     & ' itl',itl,' itl1',itl1
6764 #ifdef MOMENT
6765       if (imat.eq.1) then
6766         s1=dip(3,jj,i)*dip(3,kk,k)
6767       else
6768         s1=dip(2,jj,j)*dip(2,kk,l)
6769       endif
6770 #endif
6771       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
6772       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6773       if (j.eq.l+1) then
6774         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
6775         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6776       else
6777         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
6778         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6779       endif
6780       call transpose2(EUg(1,1,k),auxmat(1,1))
6781       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
6782       vv(1)=pizda(1,1)-pizda(2,2)
6783       vv(2)=pizda(2,1)+pizda(1,2)
6784       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6785 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
6786 #ifdef MOMENT
6787       eello6_graph4=-(s1+s2+s3+s4)
6788 #else
6789       eello6_graph4=-(s2+s3+s4)
6790 #endif
6791 C Derivatives in gamma(i-1)
6792       if (i.gt.1) then
6793 #ifdef MOMENT
6794         if (imat.eq.1) then
6795           s1=dipderg(2,jj,i)*dip(3,kk,k)
6796         else
6797           s1=dipderg(4,jj,j)*dip(2,kk,l)
6798         endif
6799 #endif
6800         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
6801         if (j.eq.l+1) then
6802           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
6803           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6804         else
6805           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
6806           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6807         endif
6808         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
6809         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6810 cd          write (2,*) 'turn6 derivatives'
6811 #ifdef MOMENT
6812           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
6813 #else
6814           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
6815 #endif
6816         else
6817 #ifdef MOMENT
6818           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
6819 #else
6820           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
6821 #endif
6822         endif
6823       endif
6824 C Derivatives in gamma(k-1)
6825 #ifdef MOMENT
6826       if (imat.eq.1) then
6827         s1=dip(3,jj,i)*dipderg(2,kk,k)
6828       else
6829         s1=dip(2,jj,j)*dipderg(4,kk,l)
6830       endif
6831 #endif
6832       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
6833       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
6834       if (j.eq.l+1) then
6835         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
6836         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
6837       else
6838         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
6839         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
6840       endif
6841       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6842       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
6843       vv(1)=pizda(1,1)-pizda(2,2)
6844       vv(2)=pizda(2,1)+pizda(1,2)
6845       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6846       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6847 #ifdef MOMENT
6848         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
6849 #else
6850         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
6851 #endif
6852       else
6853 #ifdef MOMENT
6854         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
6855 #else
6856         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
6857 #endif
6858       endif
6859 C Derivatives in gamma(j-1) or gamma(l-1)
6860       if (l.eq.j+1 .and. l.gt.1) then
6861         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
6862         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6863         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
6864         vv(1)=pizda(1,1)-pizda(2,2)
6865         vv(2)=pizda(2,1)+pizda(1,2)
6866         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6867         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
6868       else if (j.gt.1) then
6869         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
6870         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6871         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
6872         vv(1)=pizda(1,1)-pizda(2,2)
6873         vv(2)=pizda(2,1)+pizda(1,2)
6874         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6875         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6876           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
6877         else
6878           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
6879         endif
6880       endif
6881 C Cartesian derivatives.
6882       do iii=1,2
6883         do kkk=1,5
6884           do lll=1,3
6885 #ifdef MOMENT
6886             if (iii.eq.1) then
6887               if (imat.eq.1) then
6888                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
6889               else
6890                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
6891               endif
6892             else
6893               if (imat.eq.1) then
6894                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
6895               else
6896                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
6897               endif
6898             endif
6899 #endif
6900             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
6901      &        auxvec(1))
6902             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
6903             if (j.eq.l+1) then
6904               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
6905      &          b1(1,itj1),auxvec(1))
6906               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
6907             else
6908               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
6909      &          b1(1,itl1),auxvec(1))
6910               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
6911             endif
6912             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
6913      &        pizda(1,1))
6914             vv(1)=pizda(1,1)-pizda(2,2)
6915             vv(2)=pizda(2,1)+pizda(1,2)
6916             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
6917             if (swap) then
6918               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
6919 #ifdef MOMENT
6920                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
6921      &             -(s1+s2+s4)
6922 #else
6923                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
6924      &             -(s2+s4)
6925 #endif
6926                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
6927               else
6928 #ifdef MOMENT
6929                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
6930 #else
6931                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
6932 #endif
6933                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6934               endif
6935             else
6936 #ifdef MOMENT
6937               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
6938 #else
6939               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
6940 #endif
6941               if (l.eq.j+1) then
6942                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
6943               else
6944                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
6945               endif
6946             endif
6947           enddo
6948         enddo
6949       enddo
6950       return
6951       end
6952 c----------------------------------------------------------------------------
6953       double precision function eello_turn6(i,jj,kk)
6954       implicit real*8 (a-h,o-z)
6955       include 'DIMENSIONS'
6956       include 'COMMON.IOUNITS'
6957       include 'COMMON.CHAIN'
6958       include 'COMMON.DERIV'
6959       include 'COMMON.INTERACT'
6960       include 'COMMON.CONTACTS'
6961       include 'COMMON.TORSION'
6962       include 'COMMON.VAR'
6963       include 'COMMON.GEO'
6964       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
6965      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
6966      &  ggg1(3),ggg2(3)
6967       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
6968      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
6969 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
6970 C           the respective energy moment and not to the cluster cumulant.
6971       s1=0.0d0
6972       s8=0.0d0
6973       s13=0.0d0
6974 c
6975       eello_turn6=0.0d0
6976       j=i+4
6977       k=i+1
6978       l=i+3
6979       iti=itortyp(itype(i))
6980       itk=itortyp(itype(k))
6981       itk1=itortyp(itype(k+1))
6982       itl=itortyp(itype(l))
6983       itj=itortyp(itype(j))
6984 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
6985 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
6986 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6987 cd        eello6=0.0d0
6988 cd        return
6989 cd      endif
6990 cd      write (iout,*)
6991 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6992 cd     &   ' and',k,l
6993 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
6994       do iii=1,2
6995         do kkk=1,5
6996           do lll=1,3
6997             derx_turn(lll,kkk,iii)=0.0d0
6998           enddo
6999         enddo
7000       enddo
7001 cd      eij=1.0d0
7002 cd      ekl=1.0d0
7003 cd      ekont=1.0d0
7004       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7005 cd      eello6_5=0.0d0
7006 cd      write (2,*) 'eello6_5',eello6_5
7007 #ifdef MOMENT
7008       call transpose2(AEA(1,1,1),auxmat(1,1))
7009       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7010       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7011       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7012 #endif
7013       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7014       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7015       s2 = scalar2(b1(1,itk),vtemp1(1))
7016 #ifdef MOMENT
7017       call transpose2(AEA(1,1,2),atemp(1,1))
7018       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7019       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7020       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7021 #endif
7022       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7023       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7024       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7025 #ifdef MOMENT
7026       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7027       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7028       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7029       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7030       ss13 = scalar2(b1(1,itk),vtemp4(1))
7031       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7032 #endif
7033 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7034 c      s1=0.0d0
7035 c      s2=0.0d0
7036 c      s8=0.0d0
7037 c      s12=0.0d0
7038 c      s13=0.0d0
7039       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7040 C Derivatives in gamma(i+2)
7041       s1d =0.0d0
7042       s8d =0.0d0
7043 #ifdef MOMENT
7044       call transpose2(AEA(1,1,1),auxmatd(1,1))
7045       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7046       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7047       call transpose2(AEAderg(1,1,2),atempd(1,1))
7048       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7049       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7050 #endif
7051       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7052       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7053       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7054 c      s1d=0.0d0
7055 c      s2d=0.0d0
7056 c      s8d=0.0d0
7057 c      s12d=0.0d0
7058 c      s13d=0.0d0
7059       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7060 C Derivatives in gamma(i+3)
7061 #ifdef MOMENT
7062       call transpose2(AEA(1,1,1),auxmatd(1,1))
7063       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7064       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7065       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7066 #endif
7067       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7068       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7069       s2d = scalar2(b1(1,itk),vtemp1d(1))
7070 #ifdef MOMENT
7071       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7072       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7073 #endif
7074       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7075 #ifdef MOMENT
7076       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7077       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7078       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7079 #endif
7080 c      s1d=0.0d0
7081 c      s2d=0.0d0
7082 c      s8d=0.0d0
7083 c      s12d=0.0d0
7084 c      s13d=0.0d0
7085 #ifdef MOMENT
7086       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7087      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7088 #else
7089       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7090      &               -0.5d0*ekont*(s2d+s12d)
7091 #endif
7092 C Derivatives in gamma(i+4)
7093       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7094       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7095       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7096 #ifdef MOMENT
7097       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7098       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7099       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7100 #endif
7101 c      s1d=0.0d0
7102 c      s2d=0.0d0
7103 c      s8d=0.0d0
7104 C      s12d=0.0d0
7105 c      s13d=0.0d0
7106 #ifdef MOMENT
7107       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7108 #else
7109       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7110 #endif
7111 C Derivatives in gamma(i+5)
7112 #ifdef MOMENT
7113       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7114       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7115       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7116 #endif
7117       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7118       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7119       s2d = scalar2(b1(1,itk),vtemp1d(1))
7120 #ifdef MOMENT
7121       call transpose2(AEA(1,1,2),atempd(1,1))
7122       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7123       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7124 #endif
7125       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7126       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7127 #ifdef MOMENT
7128       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7129       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7130       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7131 #endif
7132 c      s1d=0.0d0
7133 c      s2d=0.0d0
7134 c      s8d=0.0d0
7135 c      s12d=0.0d0
7136 c      s13d=0.0d0
7137 #ifdef MOMENT
7138       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7139      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7140 #else
7141       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7142      &               -0.5d0*ekont*(s2d+s12d)
7143 #endif
7144 C Cartesian derivatives
7145       do iii=1,2
7146         do kkk=1,5
7147           do lll=1,3
7148 #ifdef MOMENT
7149             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7150             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7151             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7152 #endif
7153             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7154             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7155      &          vtemp1d(1))
7156             s2d = scalar2(b1(1,itk),vtemp1d(1))
7157 #ifdef MOMENT
7158             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7159             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7160             s8d = -(atempd(1,1)+atempd(2,2))*
7161      &           scalar2(cc(1,1,itl),vtemp2(1))
7162 #endif
7163             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7164      &           auxmatd(1,1))
7165             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7166             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7167 c      s1d=0.0d0
7168 c      s2d=0.0d0
7169 c      s8d=0.0d0
7170 c      s12d=0.0d0
7171 c      s13d=0.0d0
7172 #ifdef MOMENT
7173             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7174      &        - 0.5d0*(s1d+s2d)
7175 #else
7176             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7177      &        - 0.5d0*s2d
7178 #endif
7179 #ifdef MOMENT
7180             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7181      &        - 0.5d0*(s8d+s12d)
7182 #else
7183             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7184      &        - 0.5d0*s12d
7185 #endif
7186           enddo
7187         enddo
7188       enddo
7189 #ifdef MOMENT
7190       do kkk=1,5
7191         do lll=1,3
7192           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7193      &      achuj_tempd(1,1))
7194           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7195           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7196           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7197           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7198           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7199      &      vtemp4d(1))
7200           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7201           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7202           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7203         enddo
7204       enddo
7205 #endif
7206 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7207 cd     &  16*eel_turn6_num
7208 cd      goto 1112
7209       if (j.lt.nres-1) then
7210         j1=j+1
7211         j2=j-1
7212       else
7213         j1=j-1
7214         j2=j-2
7215       endif
7216       if (l.lt.nres-1) then
7217         l1=l+1
7218         l2=l-1
7219       else
7220         l1=l-1
7221         l2=l-2
7222       endif
7223       do ll=1,3
7224         ggg1(ll)=eel_turn6*g_contij(ll,1)
7225         ggg2(ll)=eel_turn6*g_contij(ll,2)
7226         ghalf=0.5d0*ggg1(ll)
7227 cd        ghalf=0.0d0
7228         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
7229      &    +ekont*derx_turn(ll,2,1)
7230         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
7231         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
7232      &    +ekont*derx_turn(ll,4,1)
7233         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
7234         ghalf=0.5d0*ggg2(ll)
7235 cd        ghalf=0.0d0
7236         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
7237      &    +ekont*derx_turn(ll,2,2)
7238         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
7239         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
7240      &    +ekont*derx_turn(ll,4,2)
7241         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
7242       enddo
7243 cd      goto 1112
7244       do m=i+1,j-1
7245         do ll=1,3
7246           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
7247         enddo
7248       enddo
7249       do m=k+1,l-1
7250         do ll=1,3
7251           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
7252         enddo
7253       enddo
7254 1112  continue
7255       do m=i+2,j2
7256         do ll=1,3
7257           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
7258         enddo
7259       enddo
7260       do m=k+2,l2
7261         do ll=1,3
7262           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
7263         enddo
7264       enddo
7265 cd      do iii=1,nres-3
7266 cd        write (2,*) iii,g_corr6_loc(iii)
7267 cd      enddo
7268       eello_turn6=ekont*eel_turn6
7269 cd      write (2,*) 'ekont',ekont
7270 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
7271       return
7272       end
7273
7274 C-----------------------------------------------------------------------------
7275       double precision function scalar(u,v)
7276 !DIR$ INLINEALWAYS scalar
7277 #ifndef OSF
7278 cDEC$ ATTRIBUTES FORCEINLINE::scalar
7279 #endif
7280       implicit none
7281       double precision u(3),v(3)
7282 cd      double precision sc
7283 cd      integer i
7284 cd      sc=0.0d0
7285 cd      do i=1,3
7286 cd        sc=sc+u(i)*v(i)
7287 cd      enddo
7288 cd      scalar=sc
7289
7290       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
7291       return
7292       end
7293 crc-------------------------------------------------
7294       SUBROUTINE MATVEC2(A1,V1,V2)
7295 !DIR$ INLINEALWAYS MATVEC2
7296 #ifndef OSF
7297 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
7298 #endif
7299       implicit real*8 (a-h,o-z)
7300       include 'DIMENSIONS'
7301       DIMENSION A1(2,2),V1(2),V2(2)
7302 c      DO 1 I=1,2
7303 c        VI=0.0
7304 c        DO 3 K=1,2
7305 c    3     VI=VI+A1(I,K)*V1(K)
7306 c        Vaux(I)=VI
7307 c    1 CONTINUE
7308
7309       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
7310       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
7311
7312       v2(1)=vaux1
7313       v2(2)=vaux2
7314       END
7315 C---------------------------------------
7316       SUBROUTINE MATMAT2(A1,A2,A3)
7317 #ifndef OSF
7318 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
7319 #endif
7320       implicit real*8 (a-h,o-z)
7321       include 'DIMENSIONS'
7322       DIMENSION A1(2,2),A2(2,2),A3(2,2)
7323 c      DIMENSION AI3(2,2)
7324 c        DO  J=1,2
7325 c          A3IJ=0.0
7326 c          DO K=1,2
7327 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
7328 c          enddo
7329 c          A3(I,J)=A3IJ
7330 c       enddo
7331 c      enddo
7332
7333       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
7334       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
7335       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
7336       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
7337
7338       A3(1,1)=AI3_11
7339       A3(2,1)=AI3_21
7340       A3(1,2)=AI3_12
7341       A3(2,2)=AI3_22
7342       END
7343
7344 c-------------------------------------------------------------------------
7345       double precision function scalar2(u,v)
7346 !DIR$ INLINEALWAYS scalar2
7347       implicit none
7348       double precision u(2),v(2)
7349       double precision sc
7350       integer i
7351       scalar2=u(1)*v(1)+u(2)*v(2)
7352       return
7353       end
7354
7355 C-----------------------------------------------------------------------------
7356
7357       subroutine transpose2(a,at)
7358 !DIR$ INLINEALWAYS transpose2
7359 #ifndef OSF
7360 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
7361 #endif
7362       implicit none
7363       double precision a(2,2),at(2,2)
7364       at(1,1)=a(1,1)
7365       at(1,2)=a(2,1)
7366       at(2,1)=a(1,2)
7367       at(2,2)=a(2,2)
7368       return
7369       end
7370 c--------------------------------------------------------------------------
7371       subroutine transpose(n,a,at)
7372       implicit none
7373       integer n,i,j
7374       double precision a(n,n),at(n,n)
7375       do i=1,n
7376         do j=1,n
7377           at(j,i)=a(i,j)
7378         enddo
7379       enddo
7380       return
7381       end
7382 C---------------------------------------------------------------------------
7383       subroutine prodmat3(a1,a2,kk,transp,prod)
7384 !DIR$ INLINEALWAYS prodmat3
7385 #ifndef OSF
7386 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
7387 #endif
7388       implicit none
7389       integer i,j
7390       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
7391       logical transp
7392 crc      double precision auxmat(2,2),prod_(2,2)
7393
7394       if (transp) then
7395 crc        call transpose2(kk(1,1),auxmat(1,1))
7396 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
7397 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7398
7399            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
7400      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
7401            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
7402      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
7403            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
7404      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
7405            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
7406      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
7407
7408       else
7409 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
7410 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
7411
7412            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
7413      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
7414            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
7415      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
7416            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
7417      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
7418            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
7419      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
7420
7421       endif
7422 c      call transpose2(a2(1,1),a2t(1,1))
7423
7424 crc      print *,transp
7425 crc      print *,((prod_(i,j),i=1,2),j=1,2)
7426 crc      print *,((prod(i,j),i=1,2),j=1,2)
7427
7428       return
7429       end
7430