source/unres/src_MD/old_F/energy_p_new.safe-setmat

   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       do k=i,j-1
1536         do l=1,3
1537           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1538         enddo
1539       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 #ifdef MPI
1966       include "mpif.h"
1967       include "COMMON.SETUP"
1968       integer IERR
1969       integer status(MPI_STATUS_SIZE)
1970 #endif
1971       include 'COMMON.IOUNITS'
1972       include 'COMMON.GEO'
1973       include 'COMMON.VAR'
1974       include 'COMMON.LOCAL'
1975       include 'COMMON.CHAIN'
1976       include 'COMMON.DERIV'
1977       include 'COMMON.INTERACT'
1978       include 'COMMON.CONTACTS'
1979       include 'COMMON.TORSION'
1980       include 'COMMON.VECTORS'
1981       include 'COMMON.FFIELD'
1982       double precision auxvec(2),auxmat(2,2)
1983 C
1984 C Compute the virtual-bond-torsional-angle dependent quantities needed
1985 C to calculate the el-loc multibody terms of various order.
1986 C
1987 c      do i=3,nres+1
1988       do i=ivec_start+2,ivec_end+2
1989         if (i .lt. nres+1) then
1990           sin1=dsin(phi(i))
1991           cos1=dcos(phi(i))
1992           sintab(i-2)=sin1
1993           costab(i-2)=cos1
1994           obrot(1,i-2)=cos1
1995           obrot(2,i-2)=sin1
1996           sin2=dsin(2*phi(i))
1997           cos2=dcos(2*phi(i))
1998           sintab2(i-2)=sin2
1999           costab2(i-2)=cos2
2000           obrot2(1,i-2)=cos2
2001           obrot2(2,i-2)=sin2
2002           Ug(1,1,i-2)=-cos1
2003           Ug(1,2,i-2)=-sin1
2004           Ug(2,1,i-2)=-sin1
2005           Ug(2,2,i-2)= cos1
2006           Ug2(1,1,i-2)=-cos2
2007           Ug2(1,2,i-2)=-sin2
2008           Ug2(2,1,i-2)=-sin2
2009           Ug2(2,2,i-2)= cos2
2010         else
2011           costab(i-2)=1.0d0
2012           sintab(i-2)=0.0d0
2013           obrot(1,i-2)=1.0d0
2014           obrot(2,i-2)=0.0d0
2015           obrot2(1,i-2)=0.0d0
2016           obrot2(2,i-2)=0.0d0
2017           Ug(1,1,i-2)=1.0d0
2018           Ug(1,2,i-2)=0.0d0
2019           Ug(2,1,i-2)=0.0d0
2020           Ug(2,2,i-2)=1.0d0
2021           Ug2(1,1,i-2)=0.0d0
2022           Ug2(1,2,i-2)=0.0d0
2023           Ug2(2,1,i-2)=0.0d0
2024           Ug2(2,2,i-2)=0.0d0
2025         endif
2026         if (i .gt. 3 .and. i .lt. nres+1) then
2027           obrot_der(1,i-2)=-sin1
2028           obrot_der(2,i-2)= cos1
2029           Ugder(1,1,i-2)= sin1
2030           Ugder(1,2,i-2)=-cos1
2031           Ugder(2,1,i-2)=-cos1
2032           Ugder(2,2,i-2)=-sin1
2033           dwacos2=cos2+cos2
2034           dwasin2=sin2+sin2
2035           obrot2_der(1,i-2)=-dwasin2
2036           obrot2_der(2,i-2)= dwacos2
2037           Ug2der(1,1,i-2)= dwasin2
2038           Ug2der(1,2,i-2)=-dwacos2
2039           Ug2der(2,1,i-2)=-dwacos2
2040           Ug2der(2,2,i-2)=-dwasin2
2041         else
2042           obrot_der(1,i-2)=0.0d0
2043           obrot_der(2,i-2)=0.0d0
2044           Ugder(1,1,i-2)=0.0d0
2045           Ugder(1,2,i-2)=0.0d0
2046           Ugder(2,1,i-2)=0.0d0
2047           Ugder(2,2,i-2)=0.0d0
2048           obrot2_der(1,i-2)=0.0d0
2049           obrot2_der(2,i-2)=0.0d0
2050           Ug2der(1,1,i-2)=0.0d0
2051           Ug2der(1,2,i-2)=0.0d0
2052           Ug2der(2,1,i-2)=0.0d0
2053           Ug2der(2,2,i-2)=0.0d0
2054         endif
2055 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2056         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2057           iti = itortyp(itype(i-2))
2058         else
2059           iti=ntortyp+1
2060         endif
2061 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2062         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2063           iti1 = itortyp(itype(i-1))
2064         else
2065           iti1=ntortyp+1
2066         endif
2067 cd        write (iout,*) '*******i',i,' iti1',iti
2068 cd        write (iout,*) 'b1',b1(:,iti)
2069 cd        write (iout,*) 'b2',b2(:,iti)
2070 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2071 c        if (i .gt. iatel_s+2) then
2072         if (i .gt. nnt+2) then
2073           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2074           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2075           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2076      &    then
2077           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2078           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2079           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2080           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2081           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2082           endif
2083         else
2084           do k=1,2
2085             Ub2(k,i-2)=0.0d0
2086             Ctobr(k,i-2)=0.0d0
2087             Dtobr2(k,i-2)=0.0d0
2088             do l=1,2
2089               EUg(l,k,i-2)=0.0d0
2090               CUg(l,k,i-2)=0.0d0
2091               DUg(l,k,i-2)=0.0d0
2092               DtUg2(l,k,i-2)=0.0d0
2093             enddo
2094           enddo
2095         endif
2096         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2097         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2098         do k=1,2
2099           muder(k,i-2)=Ub2der(k,i-2)
2100         enddo
2101 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2102         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2103           iti1 = itortyp(itype(i-1))
2104         else
2105           iti1=ntortyp+1
2106         endif
2107         do k=1,2
2108           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2109         enddo
2110 cd        write (iout,*) 'mu ',mu(:,i-2)
2111 cd        write (iout,*) 'mu1',mu1(:,i-2)
2112 cd        write (iout,*) 'mu2',mu2(:,i-2)
2113         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2114      &  then
2115         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2116         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2117         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2118         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2119         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2120 C Vectors and matrices dependent on a single virtual-bond dihedral.
2121         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2122         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2123         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2124         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2125         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2126         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2127         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2128         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2129         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2130         endif
2131       enddo
2132 C Matrices dependent on two consecutive virtual-bond dihedrals.
2133 C The order of matrices is from left to right.
2134       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2135      &then
2136       do i=ivec_start,ivec_end
2137 c      do i=2,nres-1
2138         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2139         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2140         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2141         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2142         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2143         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2144         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2145         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2146       enddo
2147       endif
2148 #ifdef MPI
2149 #ifdef DEBUG
2150 c      if (fg_rank.eq.0) then
2151         write (iout,*) "Arrays UG and UGDER before GATHER"
2152         do i=1,nres-1
2153           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2154      &     ((ug(l,k,i),l=1,2),k=1,2),
2155      &     ((ugder(l,k,i),l=1,2),k=1,2)
2156         enddo
2157         write (iout,*) "Arrays UG2 and UG2DER"
2158         do i=1,nres-1
2159           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2160      &     ((ug2(l,k,i),l=1,2),k=1,2),
2161      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2162         enddo
2163         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2164         do i=1,nres-1
2165           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2166      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2167      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2168         enddo
2169         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2170         do i=1,nres-1
2171           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2172      &     costab(i),sintab(i),costab2(i),sintab2(i)
2173         enddo
2174         write (iout,*) "Array MUDER"
2175         do i=1,nres-1
2176           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2177         enddo
2178 c      endif
2179 #endif
2180       if (nfgtasks.gt.1) then
2181         time00=MPI_Wtime()
2182 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2183 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2184 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2185 #ifdef MATGATHER
2186         write (iout,*) "MPI_ROTAT",MPI_ROTAT
2187 c        call MPI_Allgatherv(ug(1,1,ivec_start),ivec_count(fg_rank),
2188 c     &   MPI_MAT1,ug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2189 c     &   FG_COMM,IERR)
2190 c        call MPI_Allgatherv(ugder(1,1,ivec_start),ivec_count(fg_rank),
2191 c     &   MPI_MAT1,ugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2192 c     &   FG_COMM,IERR)
2193 c        call MPI_Allgatherv(ug2(1,1,ivec_start),ivec_count(fg_rank),
2194 c     &   MPI_MAT1,ug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2195 c     &   FG_COMM,IERR)
2196 c        call MPI_Allgatherv(ug2der(1,1,ivec_start),ivec_count(fg_rank),
2197 c     &   MPI_MAT1,ug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2198 c     &   FG_COMM,IERR)
2199 c        call MPI_Allgatherv(obrot(1,ivec_start),ivec_count(fg_rank),
2200 c     &   MPI_MU,obrot(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2201 c     &   FG_COMM,IERR)
2202 c        call MPI_Allgatherv(obrot2(1,ivec_start),ivec_count(fg_rank),
2203 c     &   MPI_MU,obrot2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2204 c     &   FG_COMM,IERR)
2205 c        call MPI_Allgatherv(obrot_der(1,ivec_start),ivec_count(fg_rank),
2206 c     &   MPI_MU,obrot_der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2207 c     &   FG_COMM,IERR)
2208 c        call MPI_Allgatherv(obrot2_der(1,ivec_start),
2209 c     &   ivec_count(fg_rank),
2210 c     &   MPI_MU,obrot2_der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2211 c     &   FG_COMM,IERR)
2212         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank),
2213      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2214      &   FG_COMM,IERR)
2215         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank),
2216      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2217      &   FG_COMM,IERR)
2218         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank),
2219      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2220      &   FG_COMM,IERR)
2221         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank),
2222      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2223      &   FG_COMM,IERR)
2224         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank),
2225      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2226      &   FG_COMM,IERR)
2227         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank),
2228      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2229      &   FG_COMM,IERR)
2230         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank),
2231      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2232      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2233         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank),
2234      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2235      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2236         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank),
2237      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2238      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2239         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank),
2240      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2241      &   MPI_DOUBLE_PRECISION,FG_COMM,IERR)
2242         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2243      &  then
2244         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank),
2245      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2246      &   FG_COMM,IERR)
2247         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank),
2248      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2249      &   FG_COMM,IERR)
2250         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank),
2251      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2252      &   FG_COMM,IERR)
2253         call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank),
2254      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2255      &   FG_COMM,IERR)
2256         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank),
2257      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2258      &   FG_COMM,IERR)
2259         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2260      &   ivec_count(fg_rank),
2261      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2262      &   FG_COMM,IERR)
2263         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank),
2264      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2265      &   FG_COMM,IERR)
2266         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank),
2267      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2268      &   FG_COMM,IERR)
2269         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank),
2270      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2271      &   FG_COMM,IERR)
2272         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank),
2273      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2274      &   FG_COMM,IERR)
2275         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank),
2276      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2277      &   FG_COMM,IERR)
2278         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank),
2279      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2280      &   FG_COMM,IERR)
2281         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank),
2282      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2283      &   FG_COMM,IERR)
2284         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2285      &   ivec_count(fg_rank),
2286      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2287      &   FG_COMM,IERR)
2288         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank),
2289      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2290      &   FG_COMM,IERR)
2291         call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank),
2292      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2293      &   FG_COMM,IERR)
2294         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank),
2295      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2296      &   FG_COMM,IERR)
2297         call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank),
2298      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2299      &   FG_COMM,IERR)
2300         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2301      &   ivec_count(fg_rank),
2302      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2303      &   FG_COMM,IERR)
2304         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2305      &   ivec_count(fg_rank),
2306      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2307      &   FG_COMM,IERR)
2308         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2309      &   ivec_count(fg_rank),
2310      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2311      &   MPI_MAT2,FG_COMM,IERR)
2312         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2313      &   ivec_count(fg_rank),
2314      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2315      &   MPI_MAT2,FG_COMM,IERR)
2316         endif
2317 #else
2318 c Passes matrix info through the ring
2319       isend=fg_rank
2320       irecv=fg_rank-1
2321       if (irecv.lt.0) irecv=nfgtasks-1
2322       iprev=irecv
2323       inext=fg_rank+1
2324       if (inext.ge.nfgtasks) inext=0
2325       do i=1,nfgtasks-1
2326 c        write (iout,*) "isend",isend," irecv",irecv
2327         call flush(iout)
2328         lensend=lentyp(isend)
2329         lenrecv=lentyp(irecv)
2330 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2331 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2332 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2333 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2334 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2335 c        write (iout,*) "Gather ROTAT1"
2336 c        call flush(iout)
2337 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2338 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2339 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2340 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2341 c        write (iout,*) "Gather ROTAT2"
2342 c        call flush(iout)
2343         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2344      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2345      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2346      &   iprev,4400+irecv,FG_COMM,status,IERR)
2347 c        write (iout,*) "Gather ROTAT_OLD"
2348 c        call flush(iout)
2349         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2350      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2351      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2352      &   iprev,5500+irecv,FG_COMM,status,IERR)
2353 c        write (iout,*) "Gather PRECOMP11"
2354 c        call flush(iout)
2355         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2356      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2357      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2358      &   iprev,6600+irecv,FG_COMM,status,IERR)
2359 c        write (iout,*) "Gather PRECOMP12"
2360 c        call flush(iout)
2361         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2362      &  then
2363         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2364      &   MPI_ROTAT2(lensend),inext,7700+isend,
2365      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2366      &   iprev,7700+irecv,FG_COMM,status,IERR)
2367 c        write (iout,*) "Gather PRECOMP21"
2368 c        call flush(iout)
2369         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2370      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2371      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2372      &   iprev,8800+irecv,FG_COMM,status,IERR)
2373 c        write (iout,*) "Gather PRECOMP22"
2374 c        call flush(iout)
2375         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2376      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2377      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2378      &   MPI_PRECOMP23(lenrecv),
2379      &   iprev,9900+irecv,FG_COMM,status,IERR)
2380 c        write (iout,*) "Gather PRECOMP23"
2381 c        call flush(iout)
2382         endif
2383         isend=irecv
2384         irecv=irecv-1
2385         if (irecv.lt.0) irecv=nfgtasks-1
2386       enddo
2387 #endif
2388         time_gather=time_gather+MPI_Wtime()-time00
2389       endif
2390 #ifdef DEBUG
2391 c      if (fg_rank.eq.0) then
2392         write (iout,*) "Arrays UG and UGDER"
2393         do i=1,nres-1
2394           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2395      &     ((ug(l,k,i),l=1,2),k=1,2),
2396      &     ((ugder(l,k,i),l=1,2),k=1,2)
2397         enddo
2398         write (iout,*) "Arrays UG2 and UG2DER"
2399         do i=1,nres-1
2400           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2401      &     ((ug2(l,k,i),l=1,2),k=1,2),
2402      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2403         enddo
2404         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2405         do i=1,nres-1
2406           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2407      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2408      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2409         enddo
2410         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2411         do i=1,nres-1
2412           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2413      &     costab(i),sintab(i),costab2(i),sintab2(i)
2414         enddo
2415         write (iout,*) "Array MUDER"
2416         do i=1,nres-1
2417           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2418         enddo
2419 c      endif
2420 #endif
2421 #endif
2422 cd      do i=1,nres
2423 cd        iti = itortyp(itype(i))
2424 cd        write (iout,*) i
2425 cd        do j=1,2
2426 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2427 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2428 cd        enddo
2429 cd      enddo
2430       return
2431       end
2432 C--------------------------------------------------------------------------
2433       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2434 C
2435 C This subroutine calculates the average interaction energy and its gradient
2436 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2437 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2438 C The potential depends both on the distance of peptide-group centers and on
2439 C the orientation of the CA-CA virtual bonds.
2440 C
2441       implicit real*8 (a-h,o-z)
2442       include 'DIMENSIONS'
2443       include 'COMMON.CONTROL'
2444       include 'COMMON.IOUNITS'
2445       include 'COMMON.GEO'
2446       include 'COMMON.VAR'
2447       include 'COMMON.LOCAL'
2448       include 'COMMON.CHAIN'
2449       include 'COMMON.DERIV'
2450       include 'COMMON.INTERACT'
2451       include 'COMMON.CONTACTS'
2452       include 'COMMON.TORSION'
2453       include 'COMMON.VECTORS'
2454       include 'COMMON.FFIELD'
2455       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2456      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2457       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2458      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2459       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2460 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2461 #ifdef MOMENT
2462       double precision scal_el /1.0d0/
2463 #else
2464       double precision scal_el /0.5d0/
2465 #endif
2466 C 12/13/98
2467 C 13-go grudnia roku pamietnego...
2468       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2469      &                   0.0d0,1.0d0,0.0d0,
2470      &                   0.0d0,0.0d0,1.0d0/
2471 cd      write(iout,*) 'In EELEC'
2472 cd      do i=1,nloctyp
2473 cd        write(iout,*) 'Type',i
2474 cd        write(iout,*) 'B1',B1(:,i)
2475 cd        write(iout,*) 'B2',B2(:,i)
2476 cd        write(iout,*) 'CC',CC(:,:,i)
2477 cd        write(iout,*) 'DD',DD(:,:,i)
2478 cd        write(iout,*) 'EE',EE(:,:,i)
2479 cd      enddo
2480 cd      call check_vecgrad
2481 cd      stop
2482       if (icheckgrad.eq.1) then
2483         do i=1,nres-1
2484           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2485           do k=1,3
2486             dc_norm(k,i)=dc(k,i)*fac
2487           enddo
2488 c          write (iout,*) 'i',i,' fac',fac
2489         enddo
2490       endif
2491       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2492      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2493      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2494 c        call vec_and_deriv
2495         call set_matrices
2496       endif
2497 cd      do i=1,nres-1
2498 cd        write (iout,*) 'i=',i
2499 cd        do k=1,3
2500 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2501 cd        enddo
2502 cd        do k=1,3
2503 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2504 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2505 cd        enddo
2506 cd      enddo
2507       num_conti_hb=0
2508       ees=0.0D0
2509       evdw1=0.0D0
2510       eel_loc=0.0d0
2511       eello_turn3=0.0d0
2512       eello_turn4=0.0d0
2513       ind=0
2514       do i=1,nres
2515         num_cont_hb(i)=0
2516       enddo
2517 cd      print '(a)','Enter EELEC'
2518 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2519       do i=1,nres
2520         gel_loc_loc(i)=0.0d0
2521         gcorr_loc(i)=0.0d0
2522       enddo
2523       do i=iatel_s,iatel_e
2524         dxi=dc(1,i)
2525         dyi=dc(2,i)
2526         dzi=dc(3,i)
2527         dx_normi=dc_norm(1,i)
2528         dy_normi=dc_norm(2,i)
2529         dz_normi=dc_norm(3,i)
2530         xmedi=c(1,i)+0.5d0*dxi
2531         ymedi=c(2,i)+0.5d0*dyi
2532         zmedi=c(3,i)+0.5d0*dzi
2533         num_conti=0
2534 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2535         do j=ielstart(i),ielend(i)
2536           ind=ind+1
2537           iteli=itel(i)
2538           itelj=itel(j)
2539           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2540           aaa=app(iteli,itelj)
2541           bbb=bpp(iteli,itelj)
2542           ael6i=ael6(iteli,itelj)
2543           ael3i=ael3(iteli,itelj)
2544 C Diagnostics only!!!
2545 c         aaa=0.0D0
2546 c         bbb=0.0D0
2547 c         ael6i=0.0D0
2548 c         ael3i=0.0D0
2549 C End diagnostics
2550           dxj=dc(1,j)
2551           dyj=dc(2,j)
2552           dzj=dc(3,j)
2553           dx_normj=dc_norm(1,j)
2554           dy_normj=dc_norm(2,j)
2555           dz_normj=dc_norm(3,j)
2556           xj=c(1,j)+0.5D0*dxj-xmedi
2557           yj=c(2,j)+0.5D0*dyj-ymedi
2558           zj=c(3,j)+0.5D0*dzj-zmedi
2559           rij=xj*xj+yj*yj+zj*zj
2560           rrmij=1.0D0/rij
2561           rij=dsqrt(rij)
2562           rmij=1.0D0/rij
2563           r3ij=rrmij*rmij
2564           r6ij=r3ij*r3ij
2565           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2566           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2567           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2568           fac=cosa-3.0D0*cosb*cosg
2569           ev1=aaa*r6ij*r6ij
2570 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2571           if (j.eq.i+2) ev1=scal_el*ev1
2572           ev2=bbb*r6ij
2573           fac3=ael6i*r6ij
2574           fac4=ael3i*r3ij
2575           evdwij=ev1+ev2
2576           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2577           el2=fac4*fac
2578           eesij=el1+el2
2579 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2580           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2581           ees=ees+eesij
2582           evdw1=evdw1+evdwij
2583 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2584 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2585 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2586 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2587
2588           if (energy_dec) then
2589               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
2590               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2591           endif
2592
2593 C
2594 C Calculate contributions to the Cartesian gradient.
2595 C
2596 #ifdef SPLITELE
2597           facvdw=-6*rrmij*(ev1+evdwij)
2598           facel=-3*rrmij*(el1+eesij)
2599           fac1=fac
2600           erij(1)=xj*rmij
2601           erij(2)=yj*rmij
2602           erij(3)=zj*rmij
2603 *
2604 * Radial derivatives. First process both termini of the fragment (i,j)
2605 *
2606           ggg(1)=facel*xj
2607           ggg(2)=facel*yj
2608           ggg(3)=facel*zj
2609           do k=1,3
2610             ghalf=0.5D0*ggg(k)
2611             gelc(k,i)=gelc(k,i)+ghalf
2612             gelc(k,j)=gelc(k,j)+ghalf
2613           enddo
2614 *
2615 * Loop over residues i+1 thru j-1.
2616 *
2617           do k=i+1,j-1
2618             do l=1,3
2619               gelc(l,k)=gelc(l,k)+ggg(l)
2620             enddo
2621           enddo
2622           ggg(1)=facvdw*xj
2623           ggg(2)=facvdw*yj
2624           ggg(3)=facvdw*zj
2625           do k=1,3
2626             ghalf=0.5D0*ggg(k)
2627             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2628             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2629           enddo
2630 *
2631 * Loop over residues i+1 thru j-1.
2632 *
2633           do k=i+1,j-1
2634             do l=1,3
2635               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2636             enddo
2637           enddo
2638 #else
2639           facvdw=ev1+evdwij
2640           facel=el1+eesij
2641           fac1=fac
2642           fac=-3*rrmij*(facvdw+facvdw+facel)
2643           erij(1)=xj*rmij
2644           erij(2)=yj*rmij
2645           erij(3)=zj*rmij
2646 *
2647 * Radial derivatives. First process both termini of the fragment (i,j)
2648 *
2649           ggg(1)=fac*xj
2650           ggg(2)=fac*yj
2651           ggg(3)=fac*zj
2652           do k=1,3
2653             ghalf=0.5D0*ggg(k)
2654             gelc(k,i)=gelc(k,i)+ghalf
2655             gelc(k,j)=gelc(k,j)+ghalf
2656           enddo
2657 *
2658 * Loop over residues i+1 thru j-1.
2659 *
2660           do k=i+1,j-1
2661             do l=1,3
2662               gelc(l,k)=gelc(l,k)+ggg(l)
2663             enddo
2664           enddo
2665 #endif
2666 *
2667 * Angular part
2668 *
2669           ecosa=2.0D0*fac3*fac1+fac4
2670           fac4=-3.0D0*fac4
2671           fac3=-6.0D0*fac3
2672           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2673           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2674           do k=1,3
2675             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2676             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2677           enddo
2678 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2679 cd   &          (dcosg(k),k=1,3)
2680           do k=1,3
2681             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2682           enddo
2683           do k=1,3
2684             ghalf=0.5D0*ggg(k)
2685             gelc(k,i)=gelc(k,i)+ghalf
2686      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2687      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2688             gelc(k,j)=gelc(k,j)+ghalf
2689      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2690      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2691           enddo
2692           do k=i+1,j-1
2693             do l=1,3
2694               gelc(l,k)=gelc(l,k)+ggg(l)
2695             enddo
2696           enddo
2697
2698           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2699      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2700      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2701 C
2702 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2703 C   energy of a peptide unit is assumed in the form of a second-order
2704 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2705 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2706 C   are computed for EVERY pair of non-contiguous peptide groups.
2707 C
2708           if (j.lt.nres-1) then
2709             j1=j+1
2710             j2=j-1
2711           else
2712             j1=j-1
2713             j2=j-2
2714           endif
2715           kkk=0
2716           do k=1,2
2717             do l=1,2
2718               kkk=kkk+1
2719               muij(kkk)=mu(k,i)*mu(l,j)
2720             enddo
2721           enddo
2722 cd         write (iout,*) 'EELEC: i',i,' j',j
2723 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2724 cd          write(iout,*) 'muij',muij
2725           ury=scalar(uy(1,i),erij)
2726           urz=scalar(uz(1,i),erij)
2727           vry=scalar(uy(1,j),erij)
2728           vrz=scalar(uz(1,j),erij)
2729           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2730           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2731           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2732           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2733 C For diagnostics only
2734 cd          a22=1.0d0
2735 cd          a23=1.0d0
2736 cd          a32=1.0d0
2737 cd          a33=1.0d0
2738           fac=dsqrt(-ael6i)*r3ij
2739 cd          write (2,*) 'fac=',fac
2740 C For diagnostics only
2741 cd          fac=1.0d0
2742           a22=a22*fac
2743           a23=a23*fac
2744           a32=a32*fac
2745           a33=a33*fac
2746 cd          write (iout,'(4i5,4f10.5)')
2747 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2748 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2749 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2750 cd     &      uy(:,j),uz(:,j)
2751 cd          write (iout,'(4f10.5)')
2752 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2753 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2754 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2755 cd           write (iout,'(9f10.5/)')
2756 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2757 C Derivatives of the elements of A in virtual-bond vectors
2758           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2759 cd          do k=1,3
2760 cd            do l=1,3
2761 cd              erder(k,l)=0.0d0
2762 cd            enddo
2763 cd          enddo
2764           do k=1,3
2765             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2766             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2767             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2768             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2769             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2770             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2771             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2772             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2773             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2774             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2775             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2776             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2777           enddo
2778 cd          do k=1,3
2779 cd            do l=1,3
2780 cd              uryg(k,l)=0.0d0
2781 cd              urzg(k,l)=0.0d0
2782 cd              vryg(k,l)=0.0d0
2783 cd              vrzg(k,l)=0.0d0
2784 cd            enddo
2785 cd          enddo
2786 C Compute radial contributions to the gradient
2787           facr=-3.0d0*rrmij
2788           a22der=a22*facr
2789           a23der=a23*facr
2790           a32der=a32*facr
2791           a33der=a33*facr
2792 cd          a22der=0.0d0
2793 cd          a23der=0.0d0
2794 cd          a32der=0.0d0
2795 cd          a33der=0.0d0
2796           agg(1,1)=a22der*xj
2797           agg(2,1)=a22der*yj
2798           agg(3,1)=a22der*zj
2799           agg(1,2)=a23der*xj
2800           agg(2,2)=a23der*yj
2801           agg(3,2)=a23der*zj
2802           agg(1,3)=a32der*xj
2803           agg(2,3)=a32der*yj
2804           agg(3,3)=a32der*zj
2805           agg(1,4)=a33der*xj
2806           agg(2,4)=a33der*yj
2807           agg(3,4)=a33der*zj
2808 C Add the contributions coming from er
2809           fac3=-3.0d0*fac
2810           do k=1,3
2811             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2812             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2813             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2814             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2815           enddo
2816           do k=1,3
2817 C Derivatives in DC(i)
2818             ghalf1=0.5d0*agg(k,1)
2819             ghalf2=0.5d0*agg(k,2)
2820             ghalf3=0.5d0*agg(k,3)
2821             ghalf4=0.5d0*agg(k,4)
2822             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2823      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2824             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2825      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2826             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2827      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2828             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2829      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2830 C Derivatives in DC(i+1)
2831             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2832      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2833             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2834      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2835             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2836      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2837             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2838      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2839 C Derivatives in DC(j)
2840             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2841      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2842             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2843      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2844             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2845      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2846             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2847      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2848 C Derivatives in DC(j+1) or DC(nres-1)
2849             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2850      &      -3.0d0*vryg(k,3)*ury)
2851             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2852      &      -3.0d0*vrzg(k,3)*ury)
2853             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2854      &      -3.0d0*vryg(k,3)*urz)
2855             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2856      &      -3.0d0*vrzg(k,3)*urz)
2857 cd            aggi(k,1)=ghalf1
2858 cd            aggi(k,2)=ghalf2
2859 cd            aggi(k,3)=ghalf3
2860 cd            aggi(k,4)=ghalf4
2861 C Derivatives in DC(i+1)
2862 cd            aggi1(k,1)=agg(k,1)
2863 cd            aggi1(k,2)=agg(k,2)
2864 cd            aggi1(k,3)=agg(k,3)
2865 cd            aggi1(k,4)=agg(k,4)
2866 C Derivatives in DC(j)
2867 cd            aggj(k,1)=ghalf1
2868 cd            aggj(k,2)=ghalf2
2869 cd            aggj(k,3)=ghalf3
2870 cd            aggj(k,4)=ghalf4
2871 C Derivatives in DC(j+1)
2872 cd            aggj1(k,1)=0.0d0
2873 cd            aggj1(k,2)=0.0d0
2874 cd            aggj1(k,3)=0.0d0
2875 cd            aggj1(k,4)=0.0d0
2876             if (j.eq.nres-1 .and. i.lt.j-2) then
2877               do l=1,4
2878                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2879 cd                aggj1(k,l)=agg(k,l)
2880               enddo
2881             endif
2882           enddo
2883 c          goto 11111
2884 C Check the loc-el terms by numerical integration
2885           acipa(1,1)=a22
2886           acipa(1,2)=a23
2887           acipa(2,1)=a32
2888           acipa(2,2)=a33
2889           a22=-a22
2890           a23=-a23
2891           do l=1,2
2892             do k=1,3
2893               agg(k,l)=-agg(k,l)
2894               aggi(k,l)=-aggi(k,l)
2895               aggi1(k,l)=-aggi1(k,l)
2896               aggj(k,l)=-aggj(k,l)
2897               aggj1(k,l)=-aggj1(k,l)
2898             enddo
2899           enddo
2900           if (j.lt.nres-1) then
2901             a22=-a22
2902             a32=-a32
2903             do l=1,3,2
2904               do k=1,3
2905                 agg(k,l)=-agg(k,l)
2906                 aggi(k,l)=-aggi(k,l)
2907                 aggi1(k,l)=-aggi1(k,l)
2908                 aggj(k,l)=-aggj(k,l)
2909                 aggj1(k,l)=-aggj1(k,l)
2910               enddo
2911             enddo
2912           else
2913             a22=-a22
2914             a23=-a23
2915             a32=-a32
2916             a33=-a33
2917             do l=1,4
2918               do k=1,3
2919                 agg(k,l)=-agg(k,l)
2920                 aggi(k,l)=-aggi(k,l)
2921                 aggi1(k,l)=-aggi1(k,l)
2922                 aggj(k,l)=-aggj(k,l)
2923                 aggj1(k,l)=-aggj1(k,l)
2924               enddo
2925             enddo
2926           endif
2927           ENDIF ! WCORR
2928 11111     continue
2929           IF (wel_loc.gt.0.0d0) THEN
2930 C Contribution to the local-electrostatic energy coming from the i-j pair
2931           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2932      &     +a33*muij(4)
2933 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2934
2935           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2936      &            'eelloc',i,j,eel_loc_ij
2937
2938           eel_loc=eel_loc+eel_loc_ij
2939 C Partial derivatives in virtual-bond dihedral angles gamma
2940           if (i.gt.1)
2941      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2942      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2943      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2944           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2945      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2946      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2947 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2948 cd          write(iout,*) 'agg  ',agg
2949 cd          write(iout,*) 'aggi ',aggi
2950 cd          write(iout,*) 'aggi1',aggi1
2951 cd          write(iout,*) 'aggj ',aggj
2952 cd          write(iout,*) 'aggj1',aggj1
2953
2954 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2955           do l=1,3
2956             ggg(l)=agg(l,1)*muij(1)+
2957      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2958           enddo
2959           do k=i+2,j2
2960             do l=1,3
2961               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2962             enddo
2963           enddo
2964 C Remaining derivatives of eello
2965           do l=1,3
2966             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2967      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2968             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2969      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2970             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2971      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2972             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2973      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2974           enddo
2975           ENDIF
2976           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2977 C Contributions from turns
2978             a_temp(1,1)=a22
2979             a_temp(1,2)=a23
2980             a_temp(2,1)=a32
2981             a_temp(2,2)=a33
2982             call eturn34(i,j,eello_turn3,eello_turn4)
2983           endif
2984 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2985           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2986 C
2987 C Calculate the contact function. The ith column of the array JCONT will
2988 C contain the numbers of atoms that make contacts with the atom I (of numbers
2989 C greater than I). The arrays FACONT and GACONT will contain the values of
2990 C the contact function and its derivative.
2991 c           r0ij=1.02D0*rpp(iteli,itelj)
2992 c           r0ij=1.11D0*rpp(iteli,itelj)
2993             r0ij=2.20D0*rpp(iteli,itelj)
2994 c           r0ij=1.55D0*rpp(iteli,itelj)
2995             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2996             if (fcont.gt.0.0D0) then
2997               num_conti=num_conti+1
2998               if (num_conti.gt.maxconts) then
2999                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3000      &                         ' will skip next contacts for this conf.'
3001               else
3002                 jcont_hb(num_conti,i)=j
3003                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3004      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3005 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3006 C  terms.
3007                 d_cont(num_conti,i)=rij
3008 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3009 C     --- Electrostatic-interaction matrix ---
3010                 a_chuj(1,1,num_conti,i)=a22
3011                 a_chuj(1,2,num_conti,i)=a23
3012                 a_chuj(2,1,num_conti,i)=a32
3013                 a_chuj(2,2,num_conti,i)=a33
3014 C     --- Gradient of rij
3015                 do kkk=1,3
3016                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3017                 enddo
3018 c             if (i.eq.1) then
3019 c                a_chuj(1,1,num_conti,i)=-0.61d0
3020 c                a_chuj(1,2,num_conti,i)= 0.4d0
3021 c                a_chuj(2,1,num_conti,i)= 0.65d0
3022 c                a_chuj(2,2,num_conti,i)= 0.50d0
3023 c             else if (i.eq.2) then
3024 c                a_chuj(1,1,num_conti,i)= 0.0d0
3025 c                a_chuj(1,2,num_conti,i)= 0.0d0
3026 c                a_chuj(2,1,num_conti,i)= 0.0d0
3027 c                a_chuj(2,2,num_conti,i)= 0.0d0
3028 c             endif
3029 C     --- and its gradients
3030 cd                write (iout,*) 'i',i,' j',j
3031 cd                do kkk=1,3
3032 cd                write (iout,*) 'iii 1 kkk',kkk
3033 cd                write (iout,*) agg(kkk,:)
3034 cd                enddo
3035 cd                do kkk=1,3
3036 cd                write (iout,*) 'iii 2 kkk',kkk
3037 cd                write (iout,*) aggi(kkk,:)
3038 cd                enddo
3039 cd                do kkk=1,3
3040 cd                write (iout,*) 'iii 3 kkk',kkk
3041 cd                write (iout,*) aggi1(kkk,:)
3042 cd                enddo
3043 cd                do kkk=1,3
3044 cd                write (iout,*) 'iii 4 kkk',kkk
3045 cd                write (iout,*) aggj(kkk,:)
3046 cd                enddo
3047 cd                do kkk=1,3
3048 cd                write (iout,*) 'iii 5 kkk',kkk
3049 cd                write (iout,*) aggj1(kkk,:)
3050 cd                enddo
3051                 kkll=0
3052                 do k=1,2
3053                   do l=1,2
3054                     kkll=kkll+1
3055                     do m=1,3
3056                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3057                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3058                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3059                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3060                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3061 c                      do mm=1,5
3062 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
3063 c                      enddo
3064                     enddo
3065                   enddo
3066                 enddo
3067                 ENDIF
3068                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3069 C Calculate contact energies
3070                 cosa4=4.0D0*cosa
3071                 wij=cosa-3.0D0*cosb*cosg
3072                 cosbg1=cosb+cosg
3073                 cosbg2=cosb-cosg
3074 c               fac3=dsqrt(-ael6i)/r0ij**3
3075                 fac3=dsqrt(-ael6i)*r3ij
3076 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3077                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3078                 if (ees0tmp.gt.0) then
3079                   ees0pij=dsqrt(ees0tmp)
3080                 else
3081                   ees0pij=0
3082                 endif
3083 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3084                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3085                 if (ees0tmp.gt.0) then
3086                   ees0mij=dsqrt(ees0tmp)
3087                 else
3088                   ees0mij=0
3089                 endif
3090 c               ees0mij=0.0D0
3091                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3092                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3093 C Diagnostics. Comment out or remove after debugging!
3094 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3095 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3096 c               ees0m(num_conti,i)=0.0D0
3097 C End diagnostics.
3098 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3099 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3100 C Angular derivatives of the contact function
3101                 ees0pij1=fac3/ees0pij
3102                 ees0mij1=fac3/ees0mij
3103                 fac3p=-3.0D0*fac3*rrmij
3104                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3105                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3106 c               ees0mij1=0.0D0
3107                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3108                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3109                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3110                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3111                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3112                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3113                 ecosap=ecosa1+ecosa2
3114                 ecosbp=ecosb1+ecosb2
3115                 ecosgp=ecosg1+ecosg2
3116                 ecosam=ecosa1-ecosa2
3117                 ecosbm=ecosb1-ecosb2
3118                 ecosgm=ecosg1-ecosg2
3119 C Diagnostics
3120 c               ecosap=ecosa1
3121 c               ecosbp=ecosb1
3122 c               ecosgp=ecosg1
3123 c               ecosam=0.0D0
3124 c               ecosbm=0.0D0
3125 c               ecosgm=0.0D0
3126 C End diagnostics
3127                 facont_hb(num_conti,i)=fcont
3128                 fprimcont=fprimcont/rij
3129 cd              facont_hb(num_conti,i)=1.0D0
3130 C Following line is for diagnostics.
3131 cd              fprimcont=0.0D0
3132                 do k=1,3
3133                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3134                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3135                 enddo
3136                 do k=1,3
3137                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3138                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3139                 enddo
3140                 gggp(1)=gggp(1)+ees0pijp*xj
3141                 gggp(2)=gggp(2)+ees0pijp*yj
3142                 gggp(3)=gggp(3)+ees0pijp*zj
3143                 gggm(1)=gggm(1)+ees0mijp*xj
3144                 gggm(2)=gggm(2)+ees0mijp*yj
3145                 gggm(3)=gggm(3)+ees0mijp*zj
3146 C Derivatives due to the contact function
3147                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3148                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3149                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3150                 do k=1,3
3151                   ghalfp=0.5D0*gggp(k)
3152                   ghalfm=0.5D0*gggm(k)
3153                   gacontp_hb1(k,num_conti,i)=ghalfp
3154      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3155      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3156                   gacontp_hb2(k,num_conti,i)=ghalfp
3157      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3158      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3159                   gacontp_hb3(k,num_conti,i)=gggp(k)
3160                   gacontm_hb1(k,num_conti,i)=ghalfm
3161      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3162      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3163                   gacontm_hb2(k,num_conti,i)=ghalfm
3164      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3165      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3166                   gacontm_hb3(k,num_conti,i)=gggm(k)
3167                 enddo
3168 C Diagnostics. Comment out or remove after debugging!
3169 cdiag           do k=1,3
3170 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3171 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3172 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3173 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3174 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3175 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3176 cdiag           enddo
3177               ENDIF ! wcorr
3178               endif  ! num_conti.le.maxconts
3179             endif  ! fcont.gt.0
3180           endif    ! j.gt.i+1
3181         enddo ! j
3182         num_cont_hb(i)=num_conti
3183       enddo   ! i
3184 c      write (iout,*) "Number of loop steps in EELEC:",ind
3185 cd      do i=1,nres
3186 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3187 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3188 cd      enddo
3189 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3190 ccc      eel_loc=eel_loc+eello_turn3
3191       return
3192       end
3193 C-----------------------------------------------------------------------------
3194       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3195 C Third- and fourth-order contributions from turns
3196       implicit real*8 (a-h,o-z)
3197       include 'DIMENSIONS'
3198       include 'COMMON.IOUNITS'
3199       include 'COMMON.GEO'
3200       include 'COMMON.VAR'
3201       include 'COMMON.LOCAL'
3202       include 'COMMON.CHAIN'
3203       include 'COMMON.DERIV'
3204       include 'COMMON.INTERACT'
3205       include 'COMMON.CONTACTS'
3206       include 'COMMON.TORSION'
3207       include 'COMMON.VECTORS'
3208       include 'COMMON.FFIELD'
3209       include 'COMMON.CONTROL'
3210       dimension ggg(3)
3211       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3212      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3213      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3214       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3215      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3216       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3217       if (j.eq.i+2) then
3218 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3219 C
3220 C               Third-order contributions
3221 C
3222 C                 (i+2)o----(i+3)
3223 C                      | |
3224 C                      | |
3225 C                 (i+1)o----i
3226 C
3227 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3228 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3229         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3230         call transpose2(auxmat(1,1),auxmat1(1,1))
3231         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3232         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3233         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3234      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3235 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3236 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3237 cd     &    ' eello_turn3_num',4*eello_turn3_num
3238 C Derivatives in gamma(i)
3239         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3240         call transpose2(auxmat2(1,1),auxmat3(1,1))
3241         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3242         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3243 C Derivatives in gamma(i+1)
3244         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3245         call transpose2(auxmat2(1,1),auxmat3(1,1))
3246         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3247         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3248      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3249 C Cartesian derivatives
3250         do l=1,3
3251           a_temp(1,1)=aggi(l,1)
3252           a_temp(1,2)=aggi(l,2)
3253           a_temp(2,1)=aggi(l,3)
3254           a_temp(2,2)=aggi(l,4)
3255           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3256           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3257      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3258           a_temp(1,1)=aggi1(l,1)
3259           a_temp(1,2)=aggi1(l,2)
3260           a_temp(2,1)=aggi1(l,3)
3261           a_temp(2,2)=aggi1(l,4)
3262           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3263           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3264      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3265           a_temp(1,1)=aggj(l,1)
3266           a_temp(1,2)=aggj(l,2)
3267           a_temp(2,1)=aggj(l,3)
3268           a_temp(2,2)=aggj(l,4)
3269           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3270           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3271      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3272           a_temp(1,1)=aggj1(l,1)
3273           a_temp(1,2)=aggj1(l,2)
3274           a_temp(2,1)=aggj1(l,3)
3275           a_temp(2,2)=aggj1(l,4)
3276           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3277           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3278      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3279         enddo
3280       else if (j.eq.i+3) then
3281 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3282 C
3283 C               Fourth-order contributions
3284 C
3285 C                 (i+3)o----(i+4)
3286 C                     /  |
3287 C               (i+2)o   |
3288 C                     \  |
3289 C                 (i+1)o----i
3290 C
3291 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3292 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3293         iti1=itortyp(itype(i+1))
3294         iti2=itortyp(itype(i+2))
3295         iti3=itortyp(itype(i+3))
3296         call transpose2(EUg(1,1,i+1),e1t(1,1))
3297         call transpose2(Eug(1,1,i+2),e2t(1,1))
3298         call transpose2(Eug(1,1,i+3),e3t(1,1))
3299         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3300         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3301         s1=scalar2(b1(1,iti2),auxvec(1))
3302         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3303         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3304         s2=scalar2(b1(1,iti1),auxvec(1))
3305         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3306         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3307         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3308         eello_turn4=eello_turn4-(s1+s2+s3)
3309         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3310      &      'eturn4',i,j,-(s1+s2+s3)
3311 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3312 cd     &    ' eello_turn4_num',8*eello_turn4_num
3313 C Derivatives in gamma(i)
3314         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3315         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3316         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3317         s1=scalar2(b1(1,iti2),auxvec(1))
3318         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3319         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3320         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3321 C Derivatives in gamma(i+1)
3322         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3323         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3324         s2=scalar2(b1(1,iti1),auxvec(1))
3325         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3326         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3327         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3328         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3329 C Derivatives in gamma(i+2)
3330         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3331         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3332         s1=scalar2(b1(1,iti2),auxvec(1))
3333         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3334         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3335         s2=scalar2(b1(1,iti1),auxvec(1))
3336         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3337         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3338         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3339         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3340 C Cartesian derivatives
3341 C Derivatives of this turn contributions in DC(i+2)
3342         if (j.lt.nres-1) then
3343           do l=1,3
3344             a_temp(1,1)=agg(l,1)
3345             a_temp(1,2)=agg(l,2)
3346             a_temp(2,1)=agg(l,3)
3347             a_temp(2,2)=agg(l,4)
3348             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3349             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3350             s1=scalar2(b1(1,iti2),auxvec(1))
3351             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3352             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3353             s2=scalar2(b1(1,iti1),auxvec(1))
3354             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3355             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3356             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3357             ggg(l)=-(s1+s2+s3)
3358             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3359           enddo
3360         endif
3361 C Remaining derivatives of this turn contribution
3362         do l=1,3
3363           a_temp(1,1)=aggi(l,1)
3364           a_temp(1,2)=aggi(l,2)
3365           a_temp(2,1)=aggi(l,3)
3366           a_temp(2,2)=aggi(l,4)
3367           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3368           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3369           s1=scalar2(b1(1,iti2),auxvec(1))
3370           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3371           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3372           s2=scalar2(b1(1,iti1),auxvec(1))
3373           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3374           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3375           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3376           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3377           a_temp(1,1)=aggi1(l,1)
3378           a_temp(1,2)=aggi1(l,2)
3379           a_temp(2,1)=aggi1(l,3)
3380           a_temp(2,2)=aggi1(l,4)
3381           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3382           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3383           s1=scalar2(b1(1,iti2),auxvec(1))
3384           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3385           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3386           s2=scalar2(b1(1,iti1),auxvec(1))
3387           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3388           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3389           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3390           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3391           a_temp(1,1)=aggj(l,1)
3392           a_temp(1,2)=aggj(l,2)
3393           a_temp(2,1)=aggj(l,3)
3394           a_temp(2,2)=aggj(l,4)
3395           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3396           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3397           s1=scalar2(b1(1,iti2),auxvec(1))
3398           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3399           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3400           s2=scalar2(b1(1,iti1),auxvec(1))
3401           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3402           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3403           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3404           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3405           a_temp(1,1)=aggj1(l,1)
3406           a_temp(1,2)=aggj1(l,2)
3407           a_temp(2,1)=aggj1(l,3)
3408           a_temp(2,2)=aggj1(l,4)
3409           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3410           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3411           s1=scalar2(b1(1,iti2),auxvec(1))
3412           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3413           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3414           s2=scalar2(b1(1,iti1),auxvec(1))
3415           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3416           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3417           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3418           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3419         enddo
3420       endif
3421       return
3422       end
3423 C-----------------------------------------------------------------------------
3424       subroutine vecpr(u,v,w)
3425       implicit real*8(a-h,o-z)
3426       dimension u(3),v(3),w(3)
3427       w(1)=u(2)*v(3)-u(3)*v(2)
3428       w(2)=-u(1)*v(3)+u(3)*v(1)
3429       w(3)=u(1)*v(2)-u(2)*v(1)
3430       return
3431       end
3432 C-----------------------------------------------------------------------------
3433       subroutine unormderiv(u,ugrad,unorm,ungrad)
3434 C This subroutine computes the derivatives of a normalized vector u, given
3435 C the derivatives computed without normalization conditions, ugrad. Returns
3436 C ungrad.
3437       implicit none
3438       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3439       double precision vec(3)
3440       double precision scalar
3441       integer i,j
3442 c      write (2,*) 'ugrad',ugrad
3443 c      write (2,*) 'u',u
3444       do i=1,3
3445         vec(i)=scalar(ugrad(1,i),u(1))
3446       enddo
3447 c      write (2,*) 'vec',vec
3448       do i=1,3
3449         do j=1,3
3450           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3451         enddo
3452       enddo
3453 c      write (2,*) 'ungrad',ungrad
3454       return
3455       end
3456 C-----------------------------------------------------------------------------
3457       subroutine escp_soft_sphere(evdw2,evdw2_14)
3458 C
3459 C This subroutine calculates the excluded-volume interaction energy between
3460 C peptide-group centers and side chains and its gradient in virtual-bond and
3461 C side-chain vectors.
3462 C
3463       implicit real*8 (a-h,o-z)
3464       include 'DIMENSIONS'
3465       include 'COMMON.GEO'
3466       include 'COMMON.VAR'
3467       include 'COMMON.LOCAL'
3468       include 'COMMON.CHAIN'
3469       include 'COMMON.DERIV'
3470       include 'COMMON.INTERACT'
3471       include 'COMMON.FFIELD'
3472       include 'COMMON.IOUNITS'
3473       include 'COMMON.CONTROL'
3474       dimension ggg(3)
3475       evdw2=0.0D0
3476       evdw2_14=0.0d0
3477       r0_scp=4.5d0
3478 cd    print '(a)','Enter ESCP'
3479 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3480       do i=iatscp_s,iatscp_e
3481         iteli=itel(i)
3482         xi=0.5D0*(c(1,i)+c(1,i+1))
3483         yi=0.5D0*(c(2,i)+c(2,i+1))
3484         zi=0.5D0*(c(3,i)+c(3,i+1))
3485
3486         do iint=1,nscp_gr(i)
3487
3488         do j=iscpstart(i,iint),iscpend(i,iint)
3489           itypj=itype(j)
3490 C Uncomment following three lines for SC-p interactions
3491 c         xj=c(1,nres+j)-xi
3492 c         yj=c(2,nres+j)-yi
3493 c         zj=c(3,nres+j)-zi
3494 C Uncomment following three lines for Ca-p interactions
3495           xj=c(1,j)-xi
3496           yj=c(2,j)-yi
3497           zj=c(3,j)-zi
3498           rij=xj*xj+yj*yj+zj*zj
3499           r0ij=r0_scp
3500           r0ijsq=r0ij*r0ij
3501           if (rij.lt.r0ijsq) then
3502             evdwij=0.25d0*(rij-r0ijsq)**2
3503             fac=rij-r0ijsq
3504           else
3505             evdwij=0.0d0
3506             fac=0.0d0
3507           endif
3508           evdw2=evdw2+evdwij
3509 C
3510 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3511 C
3512           ggg(1)=xj*fac
3513           ggg(2)=yj*fac
3514           ggg(3)=zj*fac
3515           if (j.lt.i) then
3516 cd          write (iout,*) 'j<i'
3517 C Uncomment following three lines for SC-p interactions
3518 c           do k=1,3
3519 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3520 c           enddo
3521           else
3522 cd          write (iout,*) 'j>i'
3523             do k=1,3
3524               ggg(k)=-ggg(k)
3525 C Uncomment following line for SC-p interactions
3526 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3527             enddo
3528           endif
3529           do k=1,3
3530             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3531           enddo
3532           kstart=min0(i+1,j)
3533           kend=max0(i-1,j-1)
3534 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3535 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3536           do k=kstart,kend
3537             do l=1,3
3538               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3539             enddo
3540           enddo
3541         enddo
3542
3543         enddo ! iint
3544       enddo ! i
3545       return
3546       end
3547 C-----------------------------------------------------------------------------
3548       subroutine escp(evdw2,evdw2_14)
3549 C
3550 C This subroutine calculates the excluded-volume interaction energy between
3551 C peptide-group centers and side chains and its gradient in virtual-bond and
3552 C side-chain vectors.
3553 C
3554       implicit real*8 (a-h,o-z)
3555       include 'DIMENSIONS'
3556       include 'COMMON.GEO'
3557       include 'COMMON.VAR'
3558       include 'COMMON.LOCAL'
3559       include 'COMMON.CHAIN'
3560       include 'COMMON.DERIV'
3561       include 'COMMON.INTERACT'
3562       include 'COMMON.FFIELD'
3563       include 'COMMON.IOUNITS'
3564       include 'COMMON.CONTROL'
3565       dimension ggg(3)
3566       evdw2=0.0D0
3567       evdw2_14=0.0d0
3568 cd    print '(a)','Enter ESCP'
3569 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3570       do i=iatscp_s,iatscp_e
3571         iteli=itel(i)
3572         xi=0.5D0*(c(1,i)+c(1,i+1))
3573         yi=0.5D0*(c(2,i)+c(2,i+1))
3574         zi=0.5D0*(c(3,i)+c(3,i+1))
3575
3576         do iint=1,nscp_gr(i)
3577
3578         do j=iscpstart(i,iint),iscpend(i,iint)
3579           itypj=itype(j)
3580 C Uncomment following three lines for SC-p interactions
3581 c         xj=c(1,nres+j)-xi
3582 c         yj=c(2,nres+j)-yi
3583 c         zj=c(3,nres+j)-zi
3584 C Uncomment following three lines for Ca-p interactions
3585           xj=c(1,j)-xi
3586           yj=c(2,j)-yi
3587           zj=c(3,j)-zi
3588           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3589           fac=rrij**expon2
3590           e1=fac*fac*aad(itypj,iteli)
3591           e2=fac*bad(itypj,iteli)
3592           if (iabs(j-i) .le. 2) then
3593             e1=scal14*e1
3594             e2=scal14*e2
3595             evdw2_14=evdw2_14+e1+e2
3596           endif
3597           evdwij=e1+e2
3598           evdw2=evdw2+evdwij
3599           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3600      &        'evdw2',i,j,evdwij
3601 C
3602 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3603 C
3604           fac=-(evdwij+e1)*rrij
3605           ggg(1)=xj*fac
3606           ggg(2)=yj*fac
3607           ggg(3)=zj*fac
3608           if (j.lt.i) then
3609 cd          write (iout,*) 'j<i'
3610 C Uncomment following three lines for SC-p interactions
3611 c           do k=1,3
3612 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3613 c           enddo
3614           else
3615 cd          write (iout,*) 'j>i'
3616             do k=1,3
3617               ggg(k)=-ggg(k)
3618 C Uncomment following line for SC-p interactions
3619 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3620             enddo
3621           endif
3622           do k=1,3
3623             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3624           enddo
3625           kstart=min0(i+1,j)
3626           kend=max0(i-1,j-1)
3627 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3628 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3629           do k=kstart,kend
3630             do l=1,3
3631               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3632             enddo
3633           enddo
3634         enddo
3635
3636         enddo ! iint
3637       enddo ! i
3638       do i=1,nct
3639         do j=1,3
3640           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3641           gradx_scp(j,i)=expon*gradx_scp(j,i)
3642         enddo
3643       enddo
3644 C******************************************************************************
3645 C
3646 C                              N O T E !!!
3647 C
3648 C To save time the factor EXPON has been extracted from ALL components
3649 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3650 C use!
3651 C
3652 C******************************************************************************
3653       return
3654       end
3655 C--------------------------------------------------------------------------
3656       subroutine edis(ehpb)
3657 C
3658 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3659 C
3660       implicit real*8 (a-h,o-z)
3661       include 'DIMENSIONS'
3662       include 'COMMON.SBRIDGE'
3663       include 'COMMON.CHAIN'
3664       include 'COMMON.DERIV'
3665       include 'COMMON.VAR'
3666       include 'COMMON.INTERACT'
3667       dimension ggg(3)
3668       ehpb=0.0D0
3669 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3670 cd    print *,'link_start=',link_start,' link_end=',link_end
3671       if (link_end.eq.0) return
3672       do i=link_start,link_end
3673 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3674 C CA-CA distance used in regularization of structure.
3675         ii=ihpb(i)
3676         jj=jhpb(i)
3677 C iii and jjj point to the residues for which the distance is assigned.
3678         if (ii.gt.nres) then
3679           iii=ii-nres
3680           jjj=jj-nres
3681         else
3682           iii=ii
3683           jjj=jj
3684         endif
3685 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3686 C    distance and angle dependent SS bond potential.
3687         if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
3688           call ssbond_ene(iii,jjj,eij)
3689           ehpb=ehpb+2*eij
3690         else
3691 C Calculate the distance between the two points and its difference from the
3692 C target distance.
3693         dd=dist(ii,jj)
3694         rdis=dd-dhpb(i)
3695 C Get the force constant corresponding to this distance.
3696         waga=forcon(i)
3697 C Calculate the contribution to energy.
3698         ehpb=ehpb+waga*rdis*rdis
3699 C
3700 C Evaluate gradient.
3701 C
3702         fac=waga*rdis/dd
3703 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3704 cd   &   ' waga=',waga,' fac=',fac
3705         do j=1,3
3706           ggg(j)=fac*(c(j,jj)-c(j,ii))
3707         enddo
3708 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3709 C If this is a SC-SC distance, we need to calculate the contributions to the
3710 C Cartesian gradient in the SC vectors (ghpbx).
3711         if (iii.lt.ii) then
3712           do j=1,3
3713             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3714             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3715           enddo
3716         endif
3717         do j=iii,jjj-1
3718           do k=1,3
3719             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3720           enddo
3721         enddo
3722         endif
3723       enddo
3724       ehpb=0.5D0*ehpb
3725       return
3726       end
3727 C--------------------------------------------------------------------------
3728       subroutine ssbond_ene(i,j,eij)
3729 C
3730 C Calculate the distance and angle dependent SS-bond potential energy
3731 C using a free-energy function derived based on RHF/6-31G** ab initio
3732 C calculations of diethyl disulfide.
3733 C
3734 C A. Liwo and U. Kozlowska, 11/24/03
3735 C
3736       implicit real*8 (a-h,o-z)
3737       include 'DIMENSIONS'
3738       include 'COMMON.SBRIDGE'
3739       include 'COMMON.CHAIN'
3740       include 'COMMON.DERIV'
3741       include 'COMMON.LOCAL'
3742       include 'COMMON.INTERACT'
3743       include 'COMMON.VAR'
3744       include 'COMMON.IOUNITS'
3745       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3746       itypi=itype(i)
3747       xi=c(1,nres+i)
3748       yi=c(2,nres+i)
3749       zi=c(3,nres+i)
3750       dxi=dc_norm(1,nres+i)
3751       dyi=dc_norm(2,nres+i)
3752       dzi=dc_norm(3,nres+i)
3753       dsci_inv=dsc_inv(itypi)
3754       itypj=itype(j)
3755       dscj_inv=dsc_inv(itypj)
3756       xj=c(1,nres+j)-xi
3757       yj=c(2,nres+j)-yi
3758       zj=c(3,nres+j)-zi
3759       dxj=dc_norm(1,nres+j)
3760       dyj=dc_norm(2,nres+j)
3761       dzj=dc_norm(3,nres+j)
3762       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3763       rij=dsqrt(rrij)
3764       erij(1)=xj*rij
3765       erij(2)=yj*rij
3766       erij(3)=zj*rij
3767       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3768       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3769       om12=dxi*dxj+dyi*dyj+dzi*dzj
3770       do k=1,3
3771         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3772         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3773       enddo
3774       rij=1.0d0/rij
3775       deltad=rij-d0cm
3776       deltat1=1.0d0-om1
3777       deltat2=1.0d0+om2
3778       deltat12=om2-om1+2.0d0
3779       cosphi=om12-om1*om2
3780       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3781      &  +akct*deltad*deltat12
3782      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3783 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3784 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3785 c     &  " deltat12",deltat12," eij",eij
3786       ed=2*akcm*deltad+akct*deltat12
3787       pom1=akct*deltad
3788       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3789       eom1=-2*akth*deltat1-pom1-om2*pom2
3790       eom2= 2*akth*deltat2+pom1-om1*pom2
3791       eom12=pom2
3792       do k=1,3
3793         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3794       enddo
3795       do k=1,3
3796         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3797      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3798         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3799      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3800       enddo
3801 C
3802 C Calculate the components of the gradient in DC and X
3803 C
3804       do k=i,j-1
3805         do l=1,3
3806           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3807         enddo
3808       enddo
3809       return
3810       end
3811 C--------------------------------------------------------------------------
3812       subroutine ebond(estr)
3813 c
3814 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
3815 c
3816       implicit real*8 (a-h,o-z)
3817       include 'DIMENSIONS'
3818       include 'COMMON.LOCAL'
3819       include 'COMMON.GEO'
3820       include 'COMMON.INTERACT'
3821       include 'COMMON.DERIV'
3822       include 'COMMON.VAR'
3823       include 'COMMON.CHAIN'
3824       include 'COMMON.IOUNITS'
3825       include 'COMMON.NAMES'
3826       include 'COMMON.FFIELD'
3827       include 'COMMON.CONTROL'
3828       include 'COMMON.SETUP'
3829       double precision u(3),ud(3)
3830       estr=0.0d0
3831       do i=ibondp_start,ibondp_end
3832         diff = vbld(i)-vbldp0
3833 c        write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
3834         estr=estr+diff*diff
3835         do j=1,3
3836           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
3837         enddo
3838 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
3839       enddo
3840       estr=0.5d0*AKP*estr
3841 c
3842 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
3843 c
3844       do i=ibond_start,ibond_end
3845         iti=itype(i)
3846         if (iti.ne.10) then
3847           nbi=nbondterm(iti)
3848           if (nbi.eq.1) then
3849             diff=vbld(i+nres)-vbldsc0(1,iti)
3850 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
3851 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
3852             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
3853             do j=1,3
3854               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
3855             enddo
3856           else
3857             do j=1,nbi
3858               diff=vbld(i+nres)-vbldsc0(j,iti)
3859               ud(j)=aksc(j,iti)*diff
3860               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
3861             enddo
3862             uprod=u(1)
3863             do j=2,nbi
3864               uprod=uprod*u(j)
3865             enddo
3866             usum=0.0d0
3867             usumsqder=0.0d0
3868             do j=1,nbi
3869               uprod1=1.0d0
3870               uprod2=1.0d0
3871               do k=1,nbi
3872                 if (k.ne.j) then
3873                   uprod1=uprod1*u(k)
3874                   uprod2=uprod2*u(k)*u(k)
3875                 endif
3876               enddo
3877               usum=usum+uprod1
3878               usumsqder=usumsqder+ud(j)*uprod2
3879             enddo
3880             estr=estr+uprod/usum
3881             do j=1,3
3882              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
3883             enddo
3884           endif
3885         endif
3886       enddo
3887       return
3888       end
3889 #ifdef CRYST_THETA
3890 C--------------------------------------------------------------------------
3891       subroutine ebend(etheta)
3892 C
3893 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
3894 C angles gamma and its derivatives in consecutive thetas and gammas.
3895 C
3896       implicit real*8 (a-h,o-z)
3897       include 'DIMENSIONS'
3898       include 'COMMON.LOCAL'
3899       include 'COMMON.GEO'
3900       include 'COMMON.INTERACT'
3901       include 'COMMON.DERIV'
3902       include 'COMMON.VAR'
3903       include 'COMMON.CHAIN'
3904       include 'COMMON.IOUNITS'
3905       include 'COMMON.NAMES'
3906       include 'COMMON.FFIELD'
3907       include 'COMMON.CONTROL'
3908       common /calcthet/ term1,term2,termm,diffak,ratak,
3909      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
3910      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
3911       double precision y(2),z(2)
3912       delta=0.02d0*pi
3913 c      time11=dexp(-2*time)
3914 c      time12=1.0d0
3915       etheta=0.0D0
3916 c     write (*,'(a,i2)') 'EBEND ICG=',icg
3917       do i=ithet_start,ithet_end
3918 C Zero the energy function and its derivative at 0 or pi.
3919         call splinthet(theta(i),0.5d0*delta,ss,ssd)
3920         it=itype(i-1)
3921         if (i.gt.3) then
3922 #ifdef OSF
3923           phii=phi(i)
3924           if (phii.ne.phii) phii=150.0
3925 #else
3926           phii=phi(i)
3927 #endif
3928           y(1)=dcos(phii)
3929           y(2)=dsin(phii)
3930         else
3931           y(1)=0.0D0
3932           y(2)=0.0D0
3933         endif
3934         if (i.lt.nres) then
3935 #ifdef OSF
3936           phii1=phi(i+1)
3937           if (phii1.ne.phii1) phii1=150.0
3938           phii1=pinorm(phii1)
3939           z(1)=cos(phii1)
3940 #else
3941           phii1=phi(i+1)
3942           z(1)=dcos(phii1)
3943 #endif
3944           z(2)=dsin(phii1)
3945         else
3946           z(1)=0.0D0
3947           z(2)=0.0D0
3948         endif
3949 C Calculate the "mean" value of theta from the part of the distribution
3950 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
3951 C In following comments this theta will be referred to as t_c.
3952         thet_pred_mean=0.0d0
3953         do k=1,2
3954           athetk=athet(k,it)
3955           bthetk=bthet(k,it)
3956           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
3957         enddo
3958         dthett=thet_pred_mean*ssd
3959         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
3960 C Derivatives of the "mean" values in gamma1 and gamma2.
3961         dthetg1=(-athet(1,it)*y(2)+athet(2,it)*y(1))*ss
3962         dthetg2=(-bthet(1,it)*z(2)+bthet(2,it)*z(1))*ss
3963         if (theta(i).gt.pi-delta) then
3964           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
3965      &         E_tc0)
3966           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
3967           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3968           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
3969      &        E_theta)
3970           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
3971      &        E_tc)
3972         else if (theta(i).lt.delta) then
3973           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
3974           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
3975           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
3976      &        E_theta)
3977           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
3978           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
3979      &        E_tc)
3980         else
3981           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
3982      &        E_theta,E_tc)
3983         endif
3984         etheta=etheta+ethetai
3985         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
3986      &      'ebend',i,ethetai
3987         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
3988         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
3989         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
3990       enddo
3991 C Ufff.... We've done all this!!!
3992       return
3993       end
3994 C---------------------------------------------------------------------------
3995       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
3996      &     E_tc)
3997       implicit real*8 (a-h,o-z)
3998       include 'DIMENSIONS'
3999       include 'COMMON.LOCAL'
4000       include 'COMMON.IOUNITS'
4001       common /calcthet/ term1,term2,termm,diffak,ratak,
4002      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4003      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4004 C Calculate the contributions to both Gaussian lobes.
4005 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4006 C The "polynomial part" of the "standard deviation" of this part of
4007 C the distribution.
4008         sig=polthet(3,it)
4009         do j=2,0,-1
4010           sig=sig*thet_pred_mean+polthet(j,it)
4011         enddo
4012 C Derivative of the "interior part" of the "standard deviation of the"
4013 C gamma-dependent Gaussian lobe in t_c.
4014         sigtc=3*polthet(3,it)
4015         do j=2,1,-1
4016           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4017         enddo
4018         sigtc=sig*sigtc
4019 C Set the parameters of both Gaussian lobes of the distribution.
4020 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4021         fac=sig*sig+sigc0(it)
4022         sigcsq=fac+fac
4023         sigc=1.0D0/sigcsq
4024 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4025         sigsqtc=-4.0D0*sigcsq*sigtc
4026 c       print *,i,sig,sigtc,sigsqtc
4027 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4028         sigtc=-sigtc/(fac*fac)
4029 C Following variable is sigma(t_c)**(-2)
4030         sigcsq=sigcsq*sigcsq
4031         sig0i=sig0(it)
4032         sig0inv=1.0D0/sig0i**2
4033         delthec=thetai-thet_pred_mean
4034         delthe0=thetai-theta0i
4035         term1=-0.5D0*sigcsq*delthec*delthec
4036         term2=-0.5D0*sig0inv*delthe0*delthe0
4037 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4038 C NaNs in taking the logarithm. We extract the largest exponent which is added
4039 C to the energy (this being the log of the distribution) at the end of energy
4040 C term evaluation for this virtual-bond angle.
4041         if (term1.gt.term2) then
4042           termm=term1
4043           term2=dexp(term2-termm)
4044           term1=1.0d0
4045         else
4046           termm=term2
4047           term1=dexp(term1-termm)
4048           term2=1.0d0
4049         endif
4050 C The ratio between the gamma-independent and gamma-dependent lobes of
4051 C the distribution is a Gaussian function of thet_pred_mean too.
4052         diffak=gthet(2,it)-thet_pred_mean
4053         ratak=diffak/gthet(3,it)**2
4054         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4055 C Let's differentiate it in thet_pred_mean NOW.
4056         aktc=ak*ratak
4057 C Now put together the distribution terms to make complete distribution.
4058         termexp=term1+ak*term2
4059         termpre=sigc+ak*sig0i
4060 C Contribution of the bending energy from this theta is just the -log of
4061 C the sum of the contributions from the two lobes and the pre-exponential
4062 C factor. Simple enough, isn't it?
4063         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4064 C NOW the derivatives!!!
4065 C 6/6/97 Take into account the deformation.
4066         E_theta=(delthec*sigcsq*term1
4067      &       +ak*delthe0*sig0inv*term2)/termexp
4068         E_tc=((sigtc+aktc*sig0i)/termpre
4069      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4070      &       aktc*term2)/termexp)
4071       return
4072       end
4073 c-----------------------------------------------------------------------------
4074       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4075       implicit real*8 (a-h,o-z)
4076       include 'DIMENSIONS'
4077       include 'COMMON.LOCAL'
4078       include 'COMMON.IOUNITS'
4079       common /calcthet/ term1,term2,termm,diffak,ratak,
4080      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4081      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4082       delthec=thetai-thet_pred_mean
4083       delthe0=thetai-theta0i
4084 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4085       t3 = thetai-thet_pred_mean
4086       t6 = t3**2
4087       t9 = term1
4088       t12 = t3*sigcsq
4089       t14 = t12+t6*sigsqtc
4090       t16 = 1.0d0
4091       t21 = thetai-theta0i
4092       t23 = t21**2
4093       t26 = term2
4094       t27 = t21*t26
4095       t32 = termexp
4096       t40 = t32**2
4097       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4098      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4099      & *(-t12*t9-ak*sig0inv*t27)
4100       return
4101       end
4102 #else
4103 C--------------------------------------------------------------------------
4104       subroutine ebend(etheta)
4105 C
4106 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4107 C angles gamma and its derivatives in consecutive thetas and gammas.
4108 C ab initio-derived potentials from
4109 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4110 C
4111       implicit real*8 (a-h,o-z)
4112       include 'DIMENSIONS'
4113       include 'COMMON.LOCAL'
4114       include 'COMMON.GEO'
4115       include 'COMMON.INTERACT'
4116       include 'COMMON.DERIV'
4117       include 'COMMON.VAR'
4118       include 'COMMON.CHAIN'
4119       include 'COMMON.IOUNITS'
4120       include 'COMMON.NAMES'
4121       include 'COMMON.FFIELD'
4122       include 'COMMON.CONTROL'
4123       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4124      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4125      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4126      & sinph1ph2(maxdouble,maxdouble)
4127       logical lprn /.false./, lprn1 /.false./
4128       etheta=0.0D0
4129       do i=ithet_start,ithet_end
4130         dethetai=0.0d0
4131         dephii=0.0d0
4132         dephii1=0.0d0
4133         theti2=0.5d0*theta(i)
4134         ityp2=ithetyp(itype(i-1))
4135         do k=1,nntheterm
4136           coskt(k)=dcos(k*theti2)
4137           sinkt(k)=dsin(k*theti2)
4138         enddo
4139         if (i.gt.3) then
4140 #ifdef OSF
4141           phii=phi(i)
4142           if (phii.ne.phii) phii=150.0
4143 #else
4144           phii=phi(i)
4145 #endif
4146           ityp1=ithetyp(itype(i-2))
4147           do k=1,nsingle
4148             cosph1(k)=dcos(k*phii)
4149             sinph1(k)=dsin(k*phii)
4150           enddo
4151         else
4152           phii=0.0d0
4153           ityp1=nthetyp+1
4154           do k=1,nsingle
4155             cosph1(k)=0.0d0
4156             sinph1(k)=0.0d0
4157           enddo
4158         endif
4159         if (i.lt.nres) then
4160 #ifdef OSF
4161           phii1=phi(i+1)
4162           if (phii1.ne.phii1) phii1=150.0
4163           phii1=pinorm(phii1)
4164 #else
4165           phii1=phi(i+1)
4166 #endif
4167           ityp3=ithetyp(itype(i))
4168           do k=1,nsingle
4169             cosph2(k)=dcos(k*phii1)
4170             sinph2(k)=dsin(k*phii1)
4171           enddo
4172         else
4173           phii1=0.0d0
4174           ityp3=nthetyp+1
4175           do k=1,nsingle
4176             cosph2(k)=0.0d0
4177             sinph2(k)=0.0d0
4178           enddo
4179         endif
4180         ethetai=aa0thet(ityp1,ityp2,ityp3)
4181         do k=1,ndouble
4182           do l=1,k-1
4183             ccl=cosph1(l)*cosph2(k-l)
4184             ssl=sinph1(l)*sinph2(k-l)
4185             scl=sinph1(l)*cosph2(k-l)
4186             csl=cosph1(l)*sinph2(k-l)
4187             cosph1ph2(l,k)=ccl-ssl
4188             cosph1ph2(k,l)=ccl+ssl
4189             sinph1ph2(l,k)=scl+csl
4190             sinph1ph2(k,l)=scl-csl
4191           enddo
4192         enddo
4193         if (lprn) then
4194         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4195      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4196         write (iout,*) "coskt and sinkt"
4197         do k=1,nntheterm
4198           write (iout,*) k,coskt(k),sinkt(k)
4199         enddo
4200         endif
4201         do k=1,ntheterm
4202           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3)*sinkt(k)
4203           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3)
4204      &      *coskt(k)
4205           if (lprn)
4206      &    write (iout,*) "k",k," aathet",aathet(k,ityp1,ityp2,ityp3),
4207      &     " ethetai",ethetai
4208         enddo
4209         if (lprn) then
4210         write (iout,*) "cosph and sinph"
4211         do k=1,nsingle
4212           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4213         enddo
4214         write (iout,*) "cosph1ph2 and sinph2ph2"
4215         do k=2,ndouble
4216           do l=1,k-1
4217             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4218      &         sinph1ph2(l,k),sinph1ph2(k,l)
4219           enddo
4220         enddo
4221         write(iout,*) "ethetai",ethetai
4222         endif
4223         do m=1,ntheterm2
4224           do k=1,nsingle
4225             aux=bbthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)
4226      &         +ccthet(k,m,ityp1,ityp2,ityp3)*sinph1(k)
4227      &         +ddthet(k,m,ityp1,ityp2,ityp3)*cosph2(k)
4228      &         +eethet(k,m,ityp1,ityp2,ityp3)*sinph2(k)
4229             ethetai=ethetai+sinkt(m)*aux
4230             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4231             dephii=dephii+k*sinkt(m)*(
4232      &          ccthet(k,m,ityp1,ityp2,ityp3)*cosph1(k)-
4233      &          bbthet(k,m,ityp1,ityp2,ityp3)*sinph1(k))
4234             dephii1=dephii1+k*sinkt(m)*(
4235      &          eethet(k,m,ityp1,ityp2,ityp3)*cosph2(k)-
4236      &          ddthet(k,m,ityp1,ityp2,ityp3)*sinph2(k))
4237             if (lprn)
4238      &      write (iout,*) "m",m," k",k," bbthet",
4239      &         bbthet(k,m,ityp1,ityp2,ityp3)," ccthet",
4240      &         ccthet(k,m,ityp1,ityp2,ityp3)," ddthet",
4241      &         ddthet(k,m,ityp1,ityp2,ityp3)," eethet",
4242      &         eethet(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4243           enddo
4244         enddo
4245         if (lprn)
4246      &  write(iout,*) "ethetai",ethetai
4247         do m=1,ntheterm3
4248           do k=2,ndouble
4249             do l=1,k-1
4250               aux=ffthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4251      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+
4252      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4253      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
4254               ethetai=ethetai+sinkt(m)*aux
4255               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4256               dephii=dephii+l*sinkt(m)*(
4257      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-
4258      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4259      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+
4260      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4261               dephii1=dephii1+(k-l)*sinkt(m)*(
4262      &           -ffthet(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+
4263      &            ffthet(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+
4264      &            ggthet(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-
4265      &            ggthet(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
4266               if (lprn) then
4267               write (iout,*) "m",m," k",k," l",l," ffthet",
4268      &            ffthet(l,k,m,ityp1,ityp2,ityp3),
4269      &            ffthet(k,l,m,ityp1,ityp2,ityp3)," ggthet",
4270      &            ggthet(l,k,m,ityp1,ityp2,ityp3),
4271      &            ggthet(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
4272               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4273      &            cosph1ph2(k,l)*sinkt(m),
4274      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4275               endif
4276             enddo
4277           enddo
4278         enddo
4279 10      continue
4280         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4281      &   i,theta(i)*rad2deg,phii*rad2deg,
4282      &   phii1*rad2deg,ethetai
4283         etheta=etheta+ethetai
4284         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4285         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4286         gloc(nphi+i-2,icg)=wang*dethetai
4287       enddo
4288       return
4289       end
4290 #endif
4291 #ifdef CRYST_SC
4292 c-----------------------------------------------------------------------------
4293       subroutine esc(escloc)
4294 C Calculate the local energy of a side chain and its derivatives in the
4295 C corresponding virtual-bond valence angles THETA and the spherical angles
4296 C ALPHA and OMEGA.
4297       implicit real*8 (a-h,o-z)
4298       include 'DIMENSIONS'
4299       include 'COMMON.GEO'
4300       include 'COMMON.LOCAL'
4301       include 'COMMON.VAR'
4302       include 'COMMON.INTERACT'
4303       include 'COMMON.DERIV'
4304       include 'COMMON.CHAIN'
4305       include 'COMMON.IOUNITS'
4306       include 'COMMON.NAMES'
4307       include 'COMMON.FFIELD'
4308       include 'COMMON.CONTROL'
4309       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4310      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4311       common /sccalc/ time11,time12,time112,theti,it,nlobit
4312       delta=0.02d0*pi
4313       escloc=0.0D0
4314 c     write (iout,'(a)') 'ESC'
4315       do i=loc_start,loc_end
4316         it=itype(i)
4317         if (it.eq.10) goto 1
4318         nlobit=nlob(it)
4319 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4320 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4321         theti=theta(i+1)-pipol
4322         x(1)=dtan(theti)
4323         x(2)=alph(i)
4324         x(3)=omeg(i)
4325
4326         if (x(2).gt.pi-delta) then
4327           xtemp(1)=x(1)
4328           xtemp(2)=pi-delta
4329           xtemp(3)=x(3)
4330           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4331           xtemp(2)=pi
4332           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4333           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4334      &        escloci,dersc(2))
4335           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4336      &        ddersc0(1),dersc(1))
4337           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4338      &        ddersc0(3),dersc(3))
4339           xtemp(2)=pi-delta
4340           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4341           xtemp(2)=pi
4342           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4343           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4344      &            dersc0(2),esclocbi,dersc02)
4345           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4346      &            dersc12,dersc01)
4347           call splinthet(x(2),0.5d0*delta,ss,ssd)
4348           dersc0(1)=dersc01
4349           dersc0(2)=dersc02
4350           dersc0(3)=0.0d0
4351           do k=1,3
4352             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4353           enddo
4354           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4355 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4356 c    &             esclocbi,ss,ssd
4357           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4358 c         escloci=esclocbi
4359 c         write (iout,*) escloci
4360         else if (x(2).lt.delta) then
4361           xtemp(1)=x(1)
4362           xtemp(2)=delta
4363           xtemp(3)=x(3)
4364           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4365           xtemp(2)=0.0d0
4366           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4367           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4368      &        escloci,dersc(2))
4369           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4370      &        ddersc0(1),dersc(1))
4371           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4372      &        ddersc0(3),dersc(3))
4373           xtemp(2)=delta
4374           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4375           xtemp(2)=0.0d0
4376           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4377           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4378      &            dersc0(2),esclocbi,dersc02)
4379           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4380      &            dersc12,dersc01)
4381           dersc0(1)=dersc01
4382           dersc0(2)=dersc02
4383           dersc0(3)=0.0d0
4384           call splinthet(x(2),0.5d0*delta,ss,ssd)
4385           do k=1,3
4386             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4387           enddo
4388           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4389 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4390 c    &             esclocbi,ss,ssd
4391           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4392 c         write (iout,*) escloci
4393         else
4394           call enesc(x,escloci,dersc,ddummy,.false.)
4395         endif
4396
4397         escloc=escloc+escloci
4398         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4399      &     'escloc',i,escloci
4400 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4401
4402         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4403      &   wscloc*dersc(1)
4404         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4405         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4406     1   continue
4407       enddo
4408       return
4409       end
4410 C---------------------------------------------------------------------------
4411       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4412       implicit real*8 (a-h,o-z)
4413       include 'DIMENSIONS'
4414       include 'COMMON.GEO'
4415       include 'COMMON.LOCAL'
4416       include 'COMMON.IOUNITS'
4417       common /sccalc/ time11,time12,time112,theti,it,nlobit
4418       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4419       double precision contr(maxlob,-1:1)
4420       logical mixed
4421 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4422         escloc_i=0.0D0
4423         do j=1,3
4424           dersc(j)=0.0D0
4425           if (mixed) ddersc(j)=0.0d0
4426         enddo
4427         x3=x(3)
4428
4429 C Because of periodicity of the dependence of the SC energy in omega we have
4430 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4431 C To avoid underflows, first compute & store the exponents.
4432
4433         do iii=-1,1
4434
4435           x(3)=x3+iii*dwapi
4436
4437           do j=1,nlobit
4438             do k=1,3
4439               z(k)=x(k)-censc(k,j,it)
4440             enddo
4441             do k=1,3
4442               Axk=0.0D0
4443               do l=1,3
4444                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4445               enddo
4446               Ax(k,j,iii)=Axk
4447             enddo
4448             expfac=0.0D0
4449             do k=1,3
4450               expfac=expfac+Ax(k,j,iii)*z(k)
4451             enddo
4452             contr(j,iii)=expfac
4453           enddo ! j
4454
4455         enddo ! iii
4456
4457         x(3)=x3
4458 C As in the case of ebend, we want to avoid underflows in exponentiation and
4459 C subsequent NaNs and INFs in energy calculation.
4460 C Find the largest exponent
4461         emin=contr(1,-1)
4462         do iii=-1,1
4463           do j=1,nlobit
4464             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4465           enddo
4466         enddo
4467         emin=0.5D0*emin
4468 cd      print *,'it=',it,' emin=',emin
4469
4470 C Compute the contribution to SC energy and derivatives
4471         do iii=-1,1
4472
4473           do j=1,nlobit
4474 #ifdef OSF
4475             adexp=bsc(j,it)-0.5D0*contr(j,iii)+emin
4476             if(adexp.ne.adexp) adexp=1.0
4477             expfac=dexp(adexp)
4478 #else
4479             expfac=dexp(bsc(j,it)-0.5D0*contr(j,iii)+emin)
4480 #endif
4481 cd          print *,'j=',j,' expfac=',expfac
4482             escloc_i=escloc_i+expfac
4483             do k=1,3
4484               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4485             enddo
4486             if (mixed) then
4487               do k=1,3,2
4488                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4489      &            +gaussc(k,2,j,it))*expfac
4490               enddo
4491             endif
4492           enddo
4493
4494         enddo ! iii
4495
4496         dersc(1)=dersc(1)/cos(theti)**2
4497         ddersc(1)=ddersc(1)/cos(theti)**2
4498         ddersc(3)=ddersc(3)
4499
4500         escloci=-(dlog(escloc_i)-emin)
4501         do j=1,3
4502           dersc(j)=dersc(j)/escloc_i
4503         enddo
4504         if (mixed) then
4505           do j=1,3,2
4506             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4507           enddo
4508         endif
4509       return
4510       end
4511 C------------------------------------------------------------------------------
4512       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4513       implicit real*8 (a-h,o-z)
4514       include 'DIMENSIONS'
4515       include 'COMMON.GEO'
4516       include 'COMMON.LOCAL'
4517       include 'COMMON.IOUNITS'
4518       common /sccalc/ time11,time12,time112,theti,it,nlobit
4519       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4520       double precision contr(maxlob)
4521       logical mixed
4522
4523       escloc_i=0.0D0
4524
4525       do j=1,3
4526         dersc(j)=0.0D0
4527       enddo
4528
4529       do j=1,nlobit
4530         do k=1,2
4531           z(k)=x(k)-censc(k,j,it)
4532         enddo
4533         z(3)=dwapi
4534         do k=1,3
4535           Axk=0.0D0
4536           do l=1,3
4537             Axk=Axk+gaussc(l,k,j,it)*z(l)
4538           enddo
4539           Ax(k,j)=Axk
4540         enddo
4541         expfac=0.0D0
4542         do k=1,3
4543           expfac=expfac+Ax(k,j)*z(k)
4544         enddo
4545         contr(j)=expfac
4546       enddo ! j
4547
4548 C As in the case of ebend, we want to avoid underflows in exponentiation and
4549 C subsequent NaNs and INFs in energy calculation.
4550 C Find the largest exponent
4551       emin=contr(1)
4552       do j=1,nlobit
4553         if (emin.gt.contr(j)) emin=contr(j)
4554       enddo
4555       emin=0.5D0*emin
4556
4557 C Compute the contribution to SC energy and derivatives
4558
4559       dersc12=0.0d0
4560       do j=1,nlobit
4561         expfac=dexp(bsc(j,it)-0.5D0*contr(j)+emin)
4562         escloc_i=escloc_i+expfac
4563         do k=1,2
4564           dersc(k)=dersc(k)+Ax(k,j)*expfac
4565         enddo
4566         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4567      &            +gaussc(1,2,j,it))*expfac
4568         dersc(3)=0.0d0
4569       enddo
4570
4571       dersc(1)=dersc(1)/cos(theti)**2
4572       dersc12=dersc12/cos(theti)**2
4573       escloci=-(dlog(escloc_i)-emin)
4574       do j=1,2
4575         dersc(j)=dersc(j)/escloc_i
4576       enddo
4577       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4578       return
4579       end
4580 #else
4581 c----------------------------------------------------------------------------------
4582       subroutine esc(escloc)
4583 C Calculate the local energy of a side chain and its derivatives in the
4584 C corresponding virtual-bond valence angles THETA and the spherical angles
4585 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4586 C added by Urszula Kozlowska. 07/11/2007
4587 C
4588       implicit real*8 (a-h,o-z)
4589       include 'DIMENSIONS'
4590       include 'COMMON.GEO'
4591       include 'COMMON.LOCAL'
4592       include 'COMMON.VAR'
4593       include 'COMMON.SCROT'
4594       include 'COMMON.INTERACT'
4595       include 'COMMON.DERIV'
4596       include 'COMMON.CHAIN'
4597       include 'COMMON.IOUNITS'
4598       include 'COMMON.NAMES'
4599       include 'COMMON.FFIELD'
4600       include 'COMMON.CONTROL'
4601       include 'COMMON.VECTORS'
4602       double precision x_prime(3),y_prime(3),z_prime(3)
4603      &    , sumene,dsc_i,dp2_i,x(65),
4604      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4605      &    de_dxx,de_dyy,de_dzz,de_dt
4606       double precision s1_t,s1_6_t,s2_t,s2_6_t
4607       double precision
4608      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4609      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4610      & dt_dCi(3),dt_dCi1(3)
4611       common /sccalc/ time11,time12,time112,theti,it,nlobit
4612       delta=0.02d0*pi
4613       escloc=0.0D0
4614       do i=loc_start,loc_end
4615         costtab(i+1) =dcos(theta(i+1))
4616         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4617         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4618         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4619         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4620         cosfac=dsqrt(cosfac2)
4621         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4622         sinfac=dsqrt(sinfac2)
4623         it=itype(i)
4624         if (it.eq.10) goto 1
4625 c
4626 C  Compute the axes of tghe local cartesian coordinates system; store in
4627 c   x_prime, y_prime and z_prime
4628 c
4629         do j=1,3
4630           x_prime(j) = 0.00
4631           y_prime(j) = 0.00
4632           z_prime(j) = 0.00
4633         enddo
4634 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
4635 C     &   dc_norm(3,i+nres)
4636         do j = 1,3
4637           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
4638           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
4639         enddo
4640         do j = 1,3
4641           z_prime(j) = -uz(j,i-1)
4642         enddo
4643 c       write (2,*) "i",i
4644 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
4645 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
4646 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
4647 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
4648 c      & " xy",scalar(x_prime(1),y_prime(1)),
4649 c      & " xz",scalar(x_prime(1),z_prime(1)),
4650 c      & " yy",scalar(y_prime(1),y_prime(1)),
4651 c      & " yz",scalar(y_prime(1),z_prime(1)),
4652 c      & " zz",scalar(z_prime(1),z_prime(1))
4653 c
4654 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
4655 C to local coordinate system. Store in xx, yy, zz.
4656 c
4657         xx=0.0d0
4658         yy=0.0d0
4659         zz=0.0d0
4660         do j = 1,3
4661           xx = xx + x_prime(j)*dc_norm(j,i+nres)
4662           yy = yy + y_prime(j)*dc_norm(j,i+nres)
4663           zz = zz + z_prime(j)*dc_norm(j,i+nres)
4664         enddo
4665
4666         xxtab(i)=xx
4667         yytab(i)=yy
4668         zztab(i)=zz
4669 C
4670 C Compute the energy of the ith side cbain
4671 C
4672 c        write (2,*) "xx",xx," yy",yy," zz",zz
4673         it=itype(i)
4674         do j = 1,65
4675           x(j) = sc_parmin(j,it)
4676         enddo
4677 #ifdef CHECK_COORD
4678 Cc diagnostics - remove later
4679         xx1 = dcos(alph(2))
4680         yy1 = dsin(alph(2))*dcos(omeg(2))
4681         zz1 = -dsin(alph(2))*dsin(omeg(2))
4682         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
4683      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
4684      &    xx1,yy1,zz1
4685 C,"  --- ", xx_w,yy_w,zz_w
4686 c end diagnostics
4687 #endif
4688         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4689      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4690      &   + x(10)*yy*zz
4691         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4692      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4693      & + x(20)*yy*zz
4694         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4695      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4696      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4697      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4698      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4699      &  +x(40)*xx*yy*zz
4700         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4701      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4702      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4703      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4704      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4705      &  +x(60)*xx*yy*zz
4706         dsc_i   = 0.743d0+x(61)
4707         dp2_i   = 1.9d0+x(62)
4708         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4709      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
4710         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4711      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
4712         s1=(1+x(63))/(0.1d0 + dscp1)
4713         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4714         s2=(1+x(65))/(0.1d0 + dscp2)
4715         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4716         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
4717      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
4718 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
4719 c     &   sumene4,
4720 c     &   dscp1,dscp2,sumene
4721 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4722         escloc = escloc + sumene
4723 c        write (2,*) "i",i," escloc",sumene,escloc
4724 #ifdef DEBUG
4725 C
4726 C This section to check the numerical derivatives of the energy of ith side
4727 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
4728 C #define DEBUG in the code to turn it on.
4729 C
4730         write (2,*) "sumene               =",sumene
4731         aincr=1.0d-7
4732         xxsave=xx
4733         xx=xx+aincr
4734         write (2,*) xx,yy,zz
4735         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4736         de_dxx_num=(sumenep-sumene)/aincr
4737         xx=xxsave
4738         write (2,*) "xx+ sumene from enesc=",sumenep
4739         yysave=yy
4740         yy=yy+aincr
4741         write (2,*) xx,yy,zz
4742         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4743         de_dyy_num=(sumenep-sumene)/aincr
4744         yy=yysave
4745         write (2,*) "yy+ sumene from enesc=",sumenep
4746         zzsave=zz
4747         zz=zz+aincr
4748         write (2,*) xx,yy,zz
4749         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4750         de_dzz_num=(sumenep-sumene)/aincr
4751         zz=zzsave
4752         write (2,*) "zz+ sumene from enesc=",sumenep
4753         costsave=cost2tab(i+1)
4754         sintsave=sint2tab(i+1)
4755         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
4756         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
4757         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
4758         de_dt_num=(sumenep-sumene)/aincr
4759         write (2,*) " t+ sumene from enesc=",sumenep
4760         cost2tab(i+1)=costsave
4761         sint2tab(i+1)=sintsave
4762 C End of diagnostics section.
4763 #endif
4764 C
4765 C Compute the gradient of esc
4766 C
4767         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
4768         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
4769         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
4770         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
4771         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
4772         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
4773         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
4774         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
4775         pom1=(sumene3*sint2tab(i+1)+sumene1)
4776      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
4777         pom2=(sumene4*cost2tab(i+1)+sumene2)
4778      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
4779         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
4780         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
4781      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
4782      &  +x(40)*yy*zz
4783         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
4784         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
4785      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
4786      &  +x(60)*yy*zz
4787         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
4788      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
4789      &        +(pom1+pom2)*pom_dx
4790 #ifdef DEBUG
4791         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
4792 #endif
4793 C
4794         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
4795         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
4796      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
4797      &  +x(40)*xx*zz
4798         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
4799         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
4800      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
4801      &  +x(59)*zz**2 +x(60)*xx*zz
4802         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
4803      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
4804      &        +(pom1-pom2)*pom_dy
4805 #ifdef DEBUG
4806         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
4807 #endif
4808 C
4809         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
4810      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
4811      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
4812      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
4813      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
4814      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
4815      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
4816      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
4817 #ifdef DEBUG
4818         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
4819 #endif
4820 C
4821         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
4822      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
4823      &  +pom1*pom_dt1+pom2*pom_dt2
4824 #ifdef DEBUG
4825         write(2,*), "de_dt = ", de_dt,de_dt_num
4826 #endif
4827 c
4828 C
4829        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
4830        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
4831        cosfac2xx=cosfac2*xx
4832        sinfac2yy=sinfac2*yy
4833        do k = 1,3
4834          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
4835      &      vbld_inv(i+1)
4836          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
4837      &      vbld_inv(i)
4838          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
4839          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
4840 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
4841 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
4842 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
4843 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
4844          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
4845          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
4846          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
4847          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
4848          dZZ_Ci1(k)=0.0d0
4849          dZZ_Ci(k)=0.0d0
4850          do j=1,3
4851            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
4852            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
4853          enddo
4854
4855          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
4856          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
4857          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
4858 c
4859          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
4860          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
4861        enddo
4862
4863        do k=1,3
4864          dXX_Ctab(k,i)=dXX_Ci(k)
4865          dXX_C1tab(k,i)=dXX_Ci1(k)
4866          dYY_Ctab(k,i)=dYY_Ci(k)
4867          dYY_C1tab(k,i)=dYY_Ci1(k)
4868          dZZ_Ctab(k,i)=dZZ_Ci(k)
4869          dZZ_C1tab(k,i)=dZZ_Ci1(k)
4870          dXX_XYZtab(k,i)=dXX_XYZ(k)
4871          dYY_XYZtab(k,i)=dYY_XYZ(k)
4872          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
4873        enddo
4874
4875        do k = 1,3
4876 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
4877 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
4878 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
4879 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
4880 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
4881 c     &    dt_dci(k)
4882 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
4883 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
4884          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
4885      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
4886          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
4887      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
4888          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
4889      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
4890        enddo
4891 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
4892 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
4893
4894 C to check gradient call subroutine check_grad
4895
4896     1 continue
4897       enddo
4898       return
4899       end
4900 c------------------------------------------------------------------------------
4901       double precision function enesc(x,xx,yy,zz,cost2,sint2)
4902       implicit none
4903       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
4904      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
4905       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
4906      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
4907      &   + x(10)*yy*zz
4908       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
4909      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
4910      & + x(20)*yy*zz
4911       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
4912      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
4913      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
4914      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
4915      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
4916      &  +x(40)*xx*yy*zz
4917       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
4918      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
4919      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
4920      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
4921      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
4922      &  +x(60)*xx*yy*zz
4923       dsc_i   = 0.743d0+x(61)
4924       dp2_i   = 1.9d0+x(62)
4925       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4926      &          *(xx*cost2+yy*sint2))
4927       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
4928      &          *(xx*cost2-yy*sint2))
4929       s1=(1+x(63))/(0.1d0 + dscp1)
4930       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
4931       s2=(1+x(65))/(0.1d0 + dscp2)
4932       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
4933       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
4934      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
4935       enesc=sumene
4936       return
4937       end
4938 #endif
4939 c------------------------------------------------------------------------------
4940       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
4941 C
4942 C This procedure calculates two-body contact function g(rij) and its derivative:
4943 C
4944 C           eps0ij                                     !       x < -1
4945 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
4946 C            0                                         !       x > 1
4947 C
4948 C where x=(rij-r0ij)/delta
4949 C
4950 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
4951 C
4952       implicit none
4953       double precision rij,r0ij,eps0ij,fcont,fprimcont
4954       double precision x,x2,x4,delta
4955 c     delta=0.02D0*r0ij
4956 c      delta=0.2D0*r0ij
4957       x=(rij-r0ij)/delta
4958       if (x.lt.-1.0D0) then
4959         fcont=eps0ij
4960         fprimcont=0.0D0
4961       else if (x.le.1.0D0) then
4962         x2=x*x
4963         x4=x2*x2
4964         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
4965         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
4966       else
4967         fcont=0.0D0
4968         fprimcont=0.0D0
4969       endif
4970       return
4971       end
4972 c------------------------------------------------------------------------------
4973       subroutine splinthet(theti,delta,ss,ssder)
4974       implicit real*8 (a-h,o-z)
4975       include 'DIMENSIONS'
4976       include 'COMMON.VAR'
4977       include 'COMMON.GEO'
4978       thetup=pi-delta
4979       thetlow=delta
4980       if (theti.gt.pipol) then
4981         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
4982       else
4983         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
4984         ssder=-ssder
4985       endif
4986       return
4987       end
4988 c------------------------------------------------------------------------------
4989       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
4990       implicit none
4991       double precision x,x0,delta,f0,f1,fprim0,f,fprim
4992       double precision ksi,ksi2,ksi3,a1,a2,a3
4993       a1=fprim0*delta/(f1-f0)
4994       a2=3.0d0-2.0d0*a1
4995       a3=a1-2.0d0
4996       ksi=(x-x0)/delta
4997       ksi2=ksi*ksi
4998       ksi3=ksi2*ksi
4999       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5000       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5001       return
5002       end
5003 c------------------------------------------------------------------------------
5004       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5005       implicit none
5006       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5007       double precision ksi,ksi2,ksi3,a1,a2,a3
5008       ksi=(x-x0)/delta
5009       ksi2=ksi*ksi
5010       ksi3=ksi2*ksi
5011       a1=fprim0x*delta
5012       a2=3*(f1x-f0x)-2*fprim0x*delta
5013       a3=fprim0x*delta-2*(f1x-f0x)
5014       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5015       return
5016       end
5017 C-----------------------------------------------------------------------------
5018 #ifdef CRYST_TOR
5019 C-----------------------------------------------------------------------------
5020       subroutine etor(etors,edihcnstr)
5021       implicit real*8 (a-h,o-z)
5022       include 'DIMENSIONS'
5023       include 'COMMON.VAR'
5024       include 'COMMON.GEO'
5025       include 'COMMON.LOCAL'
5026       include 'COMMON.TORSION'
5027       include 'COMMON.INTERACT'
5028       include 'COMMON.DERIV'
5029       include 'COMMON.CHAIN'
5030       include 'COMMON.NAMES'
5031       include 'COMMON.IOUNITS'
5032       include 'COMMON.FFIELD'
5033       include 'COMMON.TORCNSTR'
5034       include 'COMMON.CONTROL'
5035       logical lprn
5036 C Set lprn=.true. for debugging
5037       lprn=.false.
5038 c      lprn=.true.
5039       etors=0.0D0
5040       do i=iphi_start,iphi_end
5041       etors_ii=0.0D0
5042         itori=itortyp(itype(i-2))
5043         itori1=itortyp(itype(i-1))
5044         phii=phi(i)
5045         gloci=0.0D0
5046 C Proline-Proline pair is a special case...
5047         if (itori.eq.3 .and. itori1.eq.3) then
5048           if (phii.gt.-dwapi3) then
5049             cosphi=dcos(3*phii)
5050             fac=1.0D0/(1.0D0-cosphi)
5051             etorsi=v1(1,3,3)*fac
5052             etorsi=etorsi+etorsi
5053             etors=etors+etorsi-v1(1,3,3)
5054             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5055             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5056           endif
5057           do j=1,3
5058             v1ij=v1(j+1,itori,itori1)
5059             v2ij=v2(j+1,itori,itori1)
5060             cosphi=dcos(j*phii)
5061             sinphi=dsin(j*phii)
5062             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5063             if (energy_dec) etors_ii=etors_ii+
5064      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5065             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5066           enddo
5067         else
5068           do j=1,nterm_old
5069             v1ij=v1(j,itori,itori1)
5070             v2ij=v2(j,itori,itori1)
5071             cosphi=dcos(j*phii)
5072             sinphi=dsin(j*phii)
5073             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5074             if (energy_dec) etors_ii=etors_ii+
5075      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5076             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5077           enddo
5078         endif
5079         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5080              'etor',i,etors_ii
5081         if (lprn)
5082      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5083      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5084      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5085         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5086 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5087       enddo
5088 ! 6/20/98 - dihedral angle constraints
5089       edihcnstr=0.0d0
5090       do i=1,ndih_constr
5091         itori=idih_constr(i)
5092         phii=phi(itori)
5093         difi=phii-phi0(i)
5094         if (difi.gt.drange(i)) then
5095           difi=difi-drange(i)
5096           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5097           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5098         else if (difi.lt.-drange(i)) then
5099           difi=difi+drange(i)
5100           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5101           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5102         endif
5103 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5104 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5105       enddo
5106 !      write (iout,*) 'edihcnstr',edihcnstr
5107       return
5108       end
5109 c------------------------------------------------------------------------------
5110       subroutine etor_d(etors_d)
5111       etors_d=0.0d0
5112       return
5113       end
5114 c----------------------------------------------------------------------------
5115 #else
5116       subroutine etor(etors,edihcnstr)
5117       implicit real*8 (a-h,o-z)
5118       include 'DIMENSIONS'
5119       include 'COMMON.VAR'
5120       include 'COMMON.GEO'
5121       include 'COMMON.LOCAL'
5122       include 'COMMON.TORSION'
5123       include 'COMMON.INTERACT'
5124       include 'COMMON.DERIV'
5125       include 'COMMON.CHAIN'
5126       include 'COMMON.NAMES'
5127       include 'COMMON.IOUNITS'
5128       include 'COMMON.FFIELD'
5129       include 'COMMON.TORCNSTR'
5130       include 'COMMON.CONTROL'
5131       logical lprn
5132 C Set lprn=.true. for debugging
5133       lprn=.false.
5134 c     lprn=.true.
5135       etors=0.0D0
5136       do i=iphi_start,iphi_end
5137       etors_ii=0.0D0
5138         itori=itortyp(itype(i-2))
5139         itori1=itortyp(itype(i-1))
5140         phii=phi(i)
5141         gloci=0.0D0
5142 C Regular cosine and sine terms
5143         do j=1,nterm(itori,itori1)
5144           v1ij=v1(j,itori,itori1)
5145           v2ij=v2(j,itori,itori1)
5146           cosphi=dcos(j*phii)
5147           sinphi=dsin(j*phii)
5148           etors=etors+v1ij*cosphi+v2ij*sinphi
5149           if (energy_dec) etors_ii=etors_ii+
5150      &                v1ij*cosphi+v2ij*sinphi
5151           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5152         enddo
5153 C Lorentz terms
5154 C                         v1
5155 C  E = SUM ----------------------------------- - v1
5156 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5157 C
5158         cosphi=dcos(0.5d0*phii)
5159         sinphi=dsin(0.5d0*phii)
5160         do j=1,nlor(itori,itori1)
5161           vl1ij=vlor1(j,itori,itori1)
5162           vl2ij=vlor2(j,itori,itori1)
5163           vl3ij=vlor3(j,itori,itori1)
5164           pom=vl2ij*cosphi+vl3ij*sinphi
5165           pom1=1.0d0/(pom*pom+1.0d0)
5166           etors=etors+vl1ij*pom1
5167           if (energy_dec) etors_ii=etors_ii+
5168      &                vl1ij*pom1
5169           pom=-pom*pom1*pom1
5170           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5171         enddo
5172 C Subtract the constant term
5173         etors=etors-v0(itori,itori1)
5174           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5175      &         'etor',i,etors_ii-v0(itori,itori1)
5176         if (lprn)
5177      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5178      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5179      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5180         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5181 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5182       enddo
5183 ! 6/20/98 - dihedral angle constraints
5184       edihcnstr=0.0d0
5185 c      do i=1,ndih_constr
5186       do i=idihconstr_start,idihconstr_end
5187         itori=idih_constr(i)
5188         phii=phi(itori)
5189         difi=pinorm(phii-phi0(i))
5190         if (difi.gt.drange(i)) then
5191           difi=difi-drange(i)
5192           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5193           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5194         else if (difi.lt.-drange(i)) then
5195           difi=difi+drange(i)
5196           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
5197           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
5198         else
5199           difi=0.0
5200         endif
5201 cd        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
5202 cd     &    rad2deg*phi0(i),  rad2deg*drange(i),
5203 cd     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5204       enddo
5205 cd       write (iout,*) 'edihcnstr',edihcnstr
5206       return
5207       end
5208 c----------------------------------------------------------------------------
5209       subroutine etor_d(etors_d)
5210 C 6/23/01 Compute double torsional energy
5211       implicit real*8 (a-h,o-z)
5212       include 'DIMENSIONS'
5213       include 'COMMON.VAR'
5214       include 'COMMON.GEO'
5215       include 'COMMON.LOCAL'
5216       include 'COMMON.TORSION'
5217       include 'COMMON.INTERACT'
5218       include 'COMMON.DERIV'
5219       include 'COMMON.CHAIN'
5220       include 'COMMON.NAMES'
5221       include 'COMMON.IOUNITS'
5222       include 'COMMON.FFIELD'
5223       include 'COMMON.TORCNSTR'
5224       logical lprn
5225 C Set lprn=.true. for debugging
5226       lprn=.false.
5227 c     lprn=.true.
5228       etors_d=0.0D0
5229       do i=iphid_start,iphid_end
5230         itori=itortyp(itype(i-2))
5231         itori1=itortyp(itype(i-1))
5232         itori2=itortyp(itype(i))
5233         phii=phi(i)
5234         phii1=phi(i+1)
5235         gloci1=0.0D0
5236         gloci2=0.0D0
5237 C Regular cosine and sine terms
5238         do j=1,ntermd_1(itori,itori1,itori2)
5239           v1cij=v1c(1,j,itori,itori1,itori2)
5240           v1sij=v1s(1,j,itori,itori1,itori2)
5241           v2cij=v1c(2,j,itori,itori1,itori2)
5242           v2sij=v1s(2,j,itori,itori1,itori2)
5243           cosphi1=dcos(j*phii)
5244           sinphi1=dsin(j*phii)
5245           cosphi2=dcos(j*phii1)
5246           sinphi2=dsin(j*phii1)
5247           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5248      &     v2cij*cosphi2+v2sij*sinphi2
5249           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5250           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5251         enddo
5252         do k=2,ntermd_2(itori,itori1,itori2)
5253           do l=1,k-1
5254             v1cdij = v2c(k,l,itori,itori1,itori2)
5255             v2cdij = v2c(l,k,itori,itori1,itori2)
5256             v1sdij = v2s(k,l,itori,itori1,itori2)
5257             v2sdij = v2s(l,k,itori,itori1,itori2)
5258             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5259             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5260             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5261             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5262             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5263      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5264             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5265      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5266             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5267      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5268           enddo
5269         enddo
5270         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5271         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5272       enddo
5273       return
5274       end
5275 #endif
5276 c------------------------------------------------------------------------------
5277       subroutine eback_sc_corr(esccor)
5278 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5279 c        conformational states; temporarily implemented as differences
5280 c        between UNRES torsional potentials (dependent on three types of
5281 c        residues) and the torsional potentials dependent on all 20 types
5282 c        of residues computed from AM1  energy surfaces of terminally-blocked
5283 c        amino-acid residues.
5284       implicit real*8 (a-h,o-z)
5285       include 'DIMENSIONS'
5286       include 'COMMON.VAR'
5287       include 'COMMON.GEO'
5288       include 'COMMON.LOCAL'
5289       include 'COMMON.TORSION'
5290       include 'COMMON.SCCOR'
5291       include 'COMMON.INTERACT'
5292       include 'COMMON.DERIV'
5293       include 'COMMON.CHAIN'
5294       include 'COMMON.NAMES'
5295       include 'COMMON.IOUNITS'
5296       include 'COMMON.FFIELD'
5297       include 'COMMON.CONTROL'
5298       logical lprn
5299 C Set lprn=.true. for debugging
5300       lprn=.false.
5301 c      lprn=.true.
5302 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5303       esccor=0.0D0
5304       do i=iphi_start,iphi_end
5305         esccor_ii=0.0D0
5306         itori=itype(i-2)
5307         itori1=itype(i-1)
5308         phii=phi(i)
5309         gloci=0.0D0
5310         do j=1,nterm_sccor
5311           v1ij=v1sccor(j,itori,itori1)
5312           v2ij=v2sccor(j,itori,itori1)
5313           cosphi=dcos(j*phii)
5314           sinphi=dsin(j*phii)
5315           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5316           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5317         enddo
5318         if (lprn)
5319      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5320      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5321      &  (v1sccor(j,itori,itori1),j=1,6),(v2sccor(j,itori,itori1),j=1,6)
5322         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5323       enddo
5324       return
5325       end
5326 c----------------------------------------------------------------------------
5327       subroutine multibody(ecorr)
5328 C This subroutine calculates multi-body contributions to energy following
5329 C the idea of Skolnick et al. If side chains I and J make a contact and
5330 C at the same time side chains I+1 and J+1 make a contact, an extra
5331 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5332       implicit real*8 (a-h,o-z)
5333       include 'DIMENSIONS'
5334       include 'COMMON.IOUNITS'
5335       include 'COMMON.DERIV'
5336       include 'COMMON.INTERACT'
5337       include 'COMMON.CONTACTS'
5338       double precision gx(3),gx1(3)
5339       logical lprn
5340
5341 C Set lprn=.true. for debugging
5342       lprn=.false.
5343
5344       if (lprn) then
5345         write (iout,'(a)') 'Contact function values:'
5346         do i=nnt,nct-2
5347           write (iout,'(i2,20(1x,i2,f10.5))')
5348      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5349         enddo
5350       endif
5351       ecorr=0.0D0
5352       do i=nnt,nct
5353         do j=1,3
5354           gradcorr(j,i)=0.0D0
5355           gradxorr(j,i)=0.0D0
5356         enddo
5357       enddo
5358       do i=nnt,nct-2
5359
5360         DO ISHIFT = 3,4
5361
5362         i1=i+ishift
5363         num_conti=num_cont(i)
5364         num_conti1=num_cont(i1)
5365         do jj=1,num_conti
5366           j=jcont(jj,i)
5367           do kk=1,num_conti1
5368             j1=jcont(kk,i1)
5369             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5370 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5371 cd   &                   ' ishift=',ishift
5372 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5373 C The system gains extra energy.
5374               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5375             endif   ! j1==j+-ishift
5376           enddo     ! kk
5377         enddo       ! jj
5378
5379         ENDDO ! ISHIFT
5380
5381       enddo         ! i
5382       return
5383       end
5384 c------------------------------------------------------------------------------
5385       double precision function esccorr(i,j,k,l,jj,kk)
5386       implicit real*8 (a-h,o-z)
5387       include 'DIMENSIONS'
5388       include 'COMMON.IOUNITS'
5389       include 'COMMON.DERIV'
5390       include 'COMMON.INTERACT'
5391       include 'COMMON.CONTACTS'
5392       double precision gx(3),gx1(3)
5393       logical lprn
5394       lprn=.false.
5395       eij=facont(jj,i)
5396       ekl=facont(kk,k)
5397 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5398 C Calculate the multi-body contribution to energy.
5399 C Calculate multi-body contributions to the gradient.
5400 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5401 cd   & k,l,(gacont(m,kk,k),m=1,3)
5402       do m=1,3
5403         gx(m) =ekl*gacont(m,jj,i)
5404         gx1(m)=eij*gacont(m,kk,k)
5405         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5406         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5407         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5408         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5409       enddo
5410       do m=i,j-1
5411         do ll=1,3
5412           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5413         enddo
5414       enddo
5415       do m=k,l-1
5416         do ll=1,3
5417           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5418         enddo
5419       enddo
5420       esccorr=-eij*ekl
5421       return
5422       end
5423 c------------------------------------------------------------------------------
5424 #ifdef MPI
5425       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5426       implicit real*8 (a-h,o-z)
5427       include 'DIMENSIONS'
5428       integer dimen1,dimen2,atom,indx
5429       double precision buffer(dimen1,dimen2)
5430       double precision zapas
5431       common /contacts_hb/ zapas(3,maxconts,maxres,8),
5432      &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
5433      &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
5434      &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
5435       num_kont=num_cont_hb(atom)
5436       do i=1,num_kont
5437         do k=1,8
5438           do j=1,3
5439             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5440           enddo ! j
5441         enddo ! k
5442         buffer(i,indx+25)=facont_hb(i,atom)
5443         buffer(i,indx+26)=ees0p(i,atom)
5444         buffer(i,indx+27)=ees0m(i,atom)
5445         buffer(i,indx+28)=d_cont(i,atom)
5446         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
5447       enddo ! i
5448       buffer(1,indx+30)=dfloat(num_kont)
5449       return
5450       end
5451 c------------------------------------------------------------------------------
5452       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5453       implicit real*8 (a-h,o-z)
5454       include 'DIMENSIONS'
5455       integer dimen1,dimen2,atom,indx
5456       double precision buffer(dimen1,dimen2)
5457       double precision zapas
5458       common /contacts_hb/ zapas(3,maxconts,maxres,8),
5459      &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
5460      &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
5461      &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
5462       num_kont=buffer(1,indx+30)
5463       num_kont_old=num_cont_hb(atom)
5464       num_cont_hb(atom)=num_kont+num_kont_old
5465       do i=1,num_kont
5466         ii=i+num_kont_old
5467         do k=1,8
5468           do j=1,3
5469             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5470           enddo ! j
5471         enddo ! k
5472         facont_hb(ii,atom)=buffer(i,indx+25)
5473         ees0p(ii,atom)=buffer(i,indx+26)
5474         ees0m(ii,atom)=buffer(i,indx+27)
5475         d_cont(i,atom)=buffer(i,indx+28)
5476         jcont_hb(ii,atom)=buffer(i,indx+29)
5477       enddo ! i
5478       return
5479       end
5480 c------------------------------------------------------------------------------
5481 #endif
5482       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5483 C This subroutine calculates multi-body contributions to hydrogen-bonding
5484       implicit real*8 (a-h,o-z)
5485       include 'DIMENSIONS'
5486       include 'COMMON.IOUNITS'
5487 #ifdef MPI
5488       include "mpif.h"
5489       parameter (max_cont=maxconts)
5490       parameter (max_dim=2*(8*3+6))
5491       parameter (msglen1=max_cont*max_dim)
5492       parameter (msglen2=2*msglen1)
5493       integer source,CorrelType,CorrelID,Error
5494       double precision buffer(max_cont,max_dim)
5495       integer status(MPI_STATUS_SIZE)
5496 #endif
5497       include 'COMMON.SETUP'
5498       include 'COMMON.FFIELD'
5499       include 'COMMON.DERIV'
5500       include 'COMMON.INTERACT'
5501       include 'COMMON.CONTACTS'
5502       include 'COMMON.CONTROL'
5503       double precision gx(3),gx1(3),time00
5504       logical lprn,ldone
5505
5506 C Set lprn=.true. for debugging
5507       lprn=.false.
5508 #ifdef MPI
5509       n_corr=0
5510       n_corr1=0
5511       if (nfgtasks.le.1) goto 30
5512       if (lprn) then
5513         write (iout,'(a)') 'Contact function values:'
5514         do i=nnt,nct-2
5515           write (iout,'(2i3,50(1x,i2,f5.2))')
5516      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5517      &    j=1,num_cont_hb(i))
5518         enddo
5519       endif
5520 C Caution! Following code assumes that electrostatic interactions concerning
5521 C a given atom are split among at most two processors!
5522       CorrelType=477
5523       CorrelID=fg_rank+1
5524       ldone=.false.
5525       do i=1,max_cont
5526         do j=1,max_dim
5527           buffer(i,j)=0.0D0
5528         enddo
5529       enddo
5530       mm=mod(fg_rank,2)
5531 c      write (*,*) 'MyRank',MyRank,' mm',mm
5532       if (mm) 20,20,10
5533    10 continue
5534 c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5535       if (fg_rank.gt.0) then
5536 C Send correlation contributions to the preceding processor
5537         msglen=msglen1
5538         nn=num_cont_hb(iatel_s)
5539         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5540 c        write (*,*) 'The BUFFER array:'
5541 c        do i=1,nn
5542 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
5543 c        enddo
5544         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5545           msglen=msglen2
5546           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
5547 C Clear the contacts of the atom passed to the neighboring processor
5548         nn=num_cont_hb(iatel_s+1)
5549 c        do i=1,nn
5550 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
5551 c        enddo
5552             num_cont_hb(iatel_s)=0
5553         endif
5554 cd      write (iout,*) 'Processor ',fg_rank,MyRank,
5555 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5556 cd   & ' msglen=',msglen
5557 c        write (*,*) 'Processor ',fg_rank,MyRank,
5558 c     & ' is sending correlation contribution to processor',fg_rank-1,
5559 c     & ' msglen=',msglen,' CorrelType=',CorrelType
5560         time00=MPI_Wtime()
5561         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1,
5562      &    CorrelType,FG_COMM,IERROR)
5563         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5564 cd      write (iout,*) 'Processor ',fg_rank,
5565 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5566 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5567 c        write (*,*) 'Processor ',fg_rank,
5568 c     & ' has sent correlation contribution to processor',fg_rank-1,
5569 c     & ' msglen=',msglen,' CorrelID=',CorrelID
5570 c        msglen=msglen1
5571       endif ! (fg_rank.gt.0)
5572       if (ldone) goto 30
5573       ldone=.true.
5574    20 continue
5575 c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5576       if (fg_rank.lt.nfgtasks-1) then
5577 C Receive correlation contributions from the next processor
5578         msglen=msglen1
5579         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5580 cd      write (iout,*) 'Processor',fg_rank,
5581 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5582 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5583 c        write (*,*) 'Processor',fg_rank,
5584 c     &' is receiving correlation contribution from processor',fg_rank+1,
5585 c     & ' msglen=',msglen,' CorrelType=',CorrelType
5586         time00=MPI_Wtime()
5587         nbytes=-1
5588         do while (nbytes.le.0)
5589           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5590           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
5591         enddo
5592 c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
5593         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION,
5594      &    fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5595         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5596 c        write (*,*) 'Processor',fg_rank,
5597 c     &' has received correlation contribution from processor',fg_rank+1,
5598 c     & ' msglen=',msglen,' nbytes=',nbytes
5599 c        write (*,*) 'The received BUFFER array:'
5600 c        do i=1,max_cont
5601 c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
5602 c        enddo
5603         if (msglen.eq.msglen1) then
5604           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5605         else if (msglen.eq.msglen2)  then
5606           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5607           call unpack_buffer(max_cont,max_dim,iatel_e+1,30,buffer)
5608         else
5609           write (iout,*)
5610      & 'ERROR!!!! message length changed while processing correlations.'
5611           write (*,*)
5612      & 'ERROR!!!! message length changed while processing correlations.'
5613           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
5614         endif ! msglen.eq.msglen1
5615       endif ! fg_rank.lt.nfgtasks-1
5616       if (ldone) goto 30
5617       ldone=.true.
5618       goto 10
5619    30 continue
5620 #endif
5621       if (lprn) then
5622         write (iout,'(a)') 'Contact function values:'
5623         do i=nnt,nct-2
5624           write (iout,'(2i3,50(1x,i2,f5.2))')
5625      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5626      &    j=1,num_cont_hb(i))
5627         enddo
5628       endif
5629       ecorr=0.0D0
5630 C Remove the loop below after debugging !!!
5631       do i=nnt,nct
5632         do j=1,3
5633           gradcorr(j,i)=0.0D0
5634           gradxorr(j,i)=0.0D0
5635         enddo
5636       enddo
5637 C Calculate the local-electrostatic correlation terms
5638       do i=iatel_s,iatel_e+1
5639         i1=i+1
5640         num_conti=num_cont_hb(i)
5641         num_conti1=num_cont_hb(i+1)
5642         do jj=1,num_conti
5643           j=jcont_hb(jj,i)
5644           do kk=1,num_conti1
5645             j1=jcont_hb(kk,i1)
5646 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5647 c     &         ' jj=',jj,' kk=',kk
5648             if (j1.eq.j+1 .or. j1.eq.j-1) then
5649 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5650 C The system gains extra energy.
5651               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5652               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5653      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
5654               n_corr=n_corr+1
5655             else if (j1.eq.j) then
5656 C Contacts I-J and I-(J+1) occur simultaneously.
5657 C The system loses extra energy.
5658 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5659             endif
5660           enddo ! kk
5661           do kk=1,num_conti
5662             j1=jcont_hb(kk,i)
5663 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5664 c    &         ' jj=',jj,' kk=',kk
5665             if (j1.eq.j+1) then
5666 C Contacts I-J and (I+1)-J occur simultaneously.
5667 C The system loses extra energy.
5668 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5669             endif ! j1==j+1
5670           enddo ! kk
5671         enddo ! jj
5672       enddo ! i
5673       return
5674       end
5675 c------------------------------------------------------------------------------
5676       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
5677      &  n_corr1)
5678 C This subroutine calculates multi-body contributions to hydrogen-bonding
5679       implicit real*8 (a-h,o-z)
5680       include 'DIMENSIONS'
5681       include 'COMMON.IOUNITS'
5682 #ifdef MPI
5683       include 'mpif.h'
5684       parameter (max_cont=maxconts)
5685       parameter (max_dim=2*(8*3+6))
5686 c      parameter (msglen1=max_cont*max_dim*4)
5687       parameter (msglen1=max_cont*max_dim/2)
5688       parameter (msglen2=2*msglen1)
5689       integer source,CorrelType,CorrelID,Error
5690       double precision buffer(max_cont,max_dim)
5691       integer status(MPI_STATUS_SIZE)
5692 #endif
5693       include 'COMMON.SETUP'
5694       include 'COMMON.FFIELD'
5695       include 'COMMON.DERIV'
5696       include 'COMMON.INTERACT'
5697       include 'COMMON.CONTACTS'
5698       include 'COMMON.CONTROL'
5699       double precision gx(3),gx1(3)
5700       logical lprn,ldone
5701 C Set lprn=.true. for debugging
5702       lprn=.false.
5703       eturn6=0.0d0
5704 #ifdef MPI
5705       n_corr=0
5706       n_corr1=0
5707       if (fgProcs.le.1) goto 30
5708       if (lprn) then
5709         write (iout,'(a)') 'Contact function values:'
5710         do i=nnt,nct-2
5711           write (iout,'(2i3,50(1x,i2,f5.2))')
5712      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5713      &    j=1,num_cont_hb(i))
5714         enddo
5715       endif
5716 C Caution! Following code assumes that electrostatic interactions concerning
5717 C a given atom are split among at most two processors!
5718       CorrelType=477
5719       CorrelID=MyID+1
5720       ldone=.false.
5721       do i=1,max_cont
5722         do j=1,max_dim
5723           buffer(i,j)=0.0D0
5724         enddo
5725       enddo
5726       mm=mod(MyRank,2)
5727 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5728       if (mm) 20,20,10
5729    10 continue
5730 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5731       if (MyRank.gt.0) then
5732 C Send correlation contributions to the preceding processor
5733         msglen=msglen1
5734         nn=num_cont_hb(iatel_s)
5735         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5736 cd      write (iout,*) 'The BUFFER array:'
5737 cd      do i=1,nn
5738 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
5739 cd      enddo
5740         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5741           msglen=msglen2
5742             call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
5743 C Clear the contacts of the atom passed to the neighboring processor
5744         nn=num_cont_hb(iatel_s+1)
5745 cd      do i=1,nn
5746 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
5747 cd      enddo
5748             num_cont_hb(iatel_s)=0
5749         endif
5750 cd      write (*,*) 'Processor ',fg_rank,MyRank,
5751 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5752 cd   & ' msglen=',msglen
5753 cd      write (*,*) 'Processor ',MyID,MyRank,
5754 cd   & ' is sending correlation contribution to processor',fg_rank-1,
5755 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5756         time00=MPI_Wtime()
5757         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1,
5758      &     CorrelType,FG_COMM,IERROR)
5759         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5760 cd      write (*,*) 'Processor ',fg_rank,MyRank,
5761 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5762 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5763 cd      write (*,*) 'Processor ',fg_rank,
5764 cd   & ' has sent correlation contribution to processor',fg_rank-1,
5765 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5766         msglen=msglen1
5767       endif ! (MyRank.gt.0)
5768       if (ldone) goto 30
5769       ldone=.true.
5770    20 continue
5771 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5772       if (fg_rank.lt.nfgtasks-1) then
5773 C Receive correlation contributions from the next processor
5774         msglen=msglen1
5775         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5776 cd      write (iout,*) 'Processor',fg_rank,
5777 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5778 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5779 cd      write (*,*) 'Processor',fg_rank,
5780 cd   & ' is receiving correlation contribution from processor',fg_rank+1,
5781 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5782         time00=MPI_Wtime()
5783         nbytes=-1
5784         do while (nbytes.le.0)
5785           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
5786           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
5787         enddo
5788 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5789         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION,
5790      &    fg_rank+1,CorrelType,status,IERROR)
5791         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
5792 cd      write (iout,*) 'Processor',fg_rank,
5793 cd   & ' has received correlation contribution from processor',fg_rank+1,
5794 cd   & ' msglen=',msglen,' nbytes=',nbytes
5795 cd      write (iout,*) 'The received BUFFER array:'
5796 cd      do i=1,max_cont
5797 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5798 cd      enddo
5799         if (msglen.eq.msglen1) then
5800           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5801         else if (msglen.eq.msglen2)  then
5802           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5803           call unpack_buffer(max_cont,max_dim,iatel_e+1,30,buffer)
5804         else
5805           write (iout,*)
5806      & 'ERROR!!!! message length changed while processing correlations.'
5807           write (*,*)
5808      & 'ERROR!!!! message length changed while processing correlations.'
5809           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
5810         endif ! msglen.eq.msglen1
5811       endif ! fg_rank.lt.nfgtasks-1
5812       if (ldone) goto 30
5813       ldone=.true.
5814       goto 10
5815    30 continue
5816 #endif
5817       if (lprn) then
5818         write (iout,'(a)') 'Contact function values:'
5819         do i=nnt,nct-2
5820           write (iout,'(2i3,50(1x,i2,f5.2))')
5821      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5822      &    j=1,num_cont_hb(i))
5823         enddo
5824       endif
5825       ecorr=0.0D0
5826       ecorr5=0.0d0
5827       ecorr6=0.0d0
5828 C Remove the loop below after debugging !!!
5829       do i=nnt,nct
5830         do j=1,3
5831           gradcorr(j,i)=0.0D0
5832           gradxorr(j,i)=0.0D0
5833         enddo
5834       enddo
5835 C Calculate the dipole-dipole interaction energies
5836       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
5837       do i=iatel_s,iatel_e+1
5838         num_conti=num_cont_hb(i)
5839         do jj=1,num_conti
5840           j=jcont_hb(jj,i)
5841 #ifdef MOMENT
5842           call dipole(i,j,jj)
5843 #endif
5844         enddo
5845       enddo
5846       endif
5847 C Calculate the local-electrostatic correlation terms
5848       do i=iatel_s,iatel_e+1
5849         i1=i+1
5850         num_conti=num_cont_hb(i)
5851         num_conti1=num_cont_hb(i+1)
5852         do jj=1,num_conti
5853           j=jcont_hb(jj,i)
5854           do kk=1,num_conti1
5855             j1=jcont_hb(kk,i1)
5856 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5857 c     &         ' jj=',jj,' kk=',kk
5858             if (j1.eq.j+1 .or. j1.eq.j-1) then
5859 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
5860 C The system gains extra energy.
5861               n_corr=n_corr+1
5862               sqd1=dsqrt(d_cont(jj,i))
5863               sqd2=dsqrt(d_cont(kk,i1))
5864               sred_geom = sqd1*sqd2
5865               IF (sred_geom.lt.cutoff_corr) THEN
5866                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
5867      &            ekont,fprimcont)
5868 cd               write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5869 cd     &         ' jj=',jj,' kk=',kk
5870                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
5871                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
5872                 do l=1,3
5873                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
5874                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
5875                 enddo
5876                 n_corr1=n_corr1+1
5877 cd               write (iout,*) 'sred_geom=',sred_geom,
5878 cd     &          ' ekont=',ekont,' fprim=',fprimcont
5879                 call calc_eello(i,j,i+1,j1,jj,kk)
5880                 if (wcorr4.gt.0.0d0)
5881      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
5882                   if (energy_dec.and.wcorr4.gt.0.0d0)
5883      1                 write (iout,'(a6,2i5,0pf7.3)')
5884      2                'ecorr4',i,j,eello4(i,j,i+1,j1,jj,kk)
5885                 if (wcorr5.gt.0.0d0)
5886      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
5887                   if (energy_dec.and.wcorr5.gt.0.0d0)
5888      1                 write (iout,'(a6,2i5,0pf7.3)')
5889      2                'ecorr5',i,j,eello5(i,j,i+1,j1,jj,kk)
5890 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
5891 cd                write(2,*)'ijkl',i,j,i+1,j1
5892                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
5893      &               .or. wturn6.eq.0.0d0))then
5894 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
5895                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
5896                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5897      1                'ecorr6',i,j,eello6(i,j,i+1,j1,jj,kk)
5898 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
5899 cd     &            'ecorr6=',ecorr6
5900 cd                write (iout,'(4e15.5)') sred_geom,
5901 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
5902 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
5903 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
5904                 else if (wturn6.gt.0.0d0
5905      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
5906 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
5907                   eturn6=eturn6+eello_turn6(i,jj,kk)
5908                   if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5909      1                 'eturn6',i,j,eello_turn6(i,jj,kk)
5910 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
5911                 endif
5912               ENDIF
5913 1111          continue
5914             else if (j1.eq.j) then
5915 C Contacts I-J and I-(J+1) occur simultaneously.
5916 C The system loses extra energy.
5917 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
5918             endif
5919           enddo ! kk
5920           do kk=1,num_conti
5921             j1=jcont_hb(kk,i)
5922 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5923 c    &         ' jj=',jj,' kk=',kk
5924             if (j1.eq.j+1) then
5925 C Contacts I-J and (I+1)-J occur simultaneously.
5926 C The system loses extra energy.
5927 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
5928             endif ! j1==j+1
5929           enddo ! kk
5930         enddo ! jj
5931       enddo ! i
5932       return
5933       end
5934 c------------------------------------------------------------------------------
5935       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
5936       implicit real*8 (a-h,o-z)
5937       include 'DIMENSIONS'
5938       include 'COMMON.IOUNITS'
5939       include 'COMMON.DERIV'
5940       include 'COMMON.INTERACT'
5941       include 'COMMON.CONTACTS'
5942       double precision gx(3),gx1(3)
5943       logical lprn
5944       lprn=.false.
5945       eij=facont_hb(jj,i)
5946       ekl=facont_hb(kk,k)
5947       ees0pij=ees0p(jj,i)
5948       ees0pkl=ees0p(kk,k)
5949       ees0mij=ees0m(jj,i)
5950       ees0mkl=ees0m(kk,k)
5951       ekont=eij*ekl
5952       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
5953 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
5954 C Following 4 lines for diagnostics.
5955 cd    ees0pkl=0.0D0
5956 cd    ees0pij=1.0D0
5957 cd    ees0mkl=0.0D0
5958 cd    ees0mij=1.0D0
5959 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
5960 c    &   ' and',k,l
5961 c     write (iout,*)'Contacts have occurred for peptide groups',
5962 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
5963 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
5964 C Calculate the multi-body contribution to energy.
5965       ecorr=ecorr+ekont*ees
5966 C Calculate multi-body contributions to the gradient.
5967       do ll=1,3
5968         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
5969         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
5970      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
5971      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
5972         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
5973      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
5974      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
5975         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
5976         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
5977      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
5978      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
5979         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
5980      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
5981      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
5982       enddo
5983       do m=i+1,j-1
5984         do ll=1,3
5985           gradcorr(ll,m)=gradcorr(ll,m)+
5986      &     ees*ekl*gacont_hbr(ll,jj,i)-
5987      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
5988      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
5989         enddo
5990       enddo
5991       do m=k+1,l-1
5992         do ll=1,3
5993           gradcorr(ll,m)=gradcorr(ll,m)+
5994      &     ees*eij*gacont_hbr(ll,kk,k)-
5995      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
5996      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
5997         enddo
5998       enddo
5999       ehbcorr=ekont*ees
6000       return
6001       end
6002 #ifdef MOMENT
6003 C---------------------------------------------------------------------------
6004       subroutine dipole(i,j,jj)
6005       implicit real*8 (a-h,o-z)
6006       include 'DIMENSIONS'
6007       include 'COMMON.IOUNITS'
6008       include 'COMMON.CHAIN'
6009       include 'COMMON.FFIELD'
6010       include 'COMMON.DERIV'
6011       include 'COMMON.INTERACT'
6012       include 'COMMON.CONTACTS'
6013       include 'COMMON.TORSION'
6014       include 'COMMON.VAR'
6015       include 'COMMON.GEO'
6016       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6017      &  auxmat(2,2)
6018       iti1 = itortyp(itype(i+1))
6019       if (j.lt.nres-1) then
6020         itj1 = itortyp(itype(j+1))
6021       else
6022         itj1=ntortyp+1
6023       endif
6024       do iii=1,2
6025         dipi(iii,1)=Ub2(iii,i)
6026         dipderi(iii)=Ub2der(iii,i)
6027         dipi(iii,2)=b1(iii,iti1)
6028         dipj(iii,1)=Ub2(iii,j)
6029         dipderj(iii)=Ub2der(iii,j)
6030         dipj(iii,2)=b1(iii,itj1)
6031       enddo
6032       kkk=0
6033       do iii=1,2
6034         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6035         do jjj=1,2
6036           kkk=kkk+1
6037           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6038         enddo
6039       enddo
6040       do kkk=1,5
6041         do lll=1,3
6042           mmm=0
6043           do iii=1,2
6044             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6045      &        auxvec(1))
6046             do jjj=1,2
6047               mmm=mmm+1
6048               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6049             enddo
6050           enddo
6051         enddo
6052       enddo
6053       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6054       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6055       do iii=1,2
6056         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6057       enddo
6058       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6059       do iii=1,2
6060         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6061       enddo
6062       return
6063       end
6064 #endif
6065 C---------------------------------------------------------------------------
6066       subroutine calc_eello(i,j,k,l,jj,kk)
6067 C
6068 C This subroutine computes matrices and vectors needed to calculate
6069 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6070 C
6071       implicit real*8 (a-h,o-z)
6072       include 'DIMENSIONS'
6073       include 'COMMON.IOUNITS'
6074       include 'COMMON.CHAIN'
6075       include 'COMMON.DERIV'
6076       include 'COMMON.INTERACT'
6077       include 'COMMON.CONTACTS'
6078       include 'COMMON.TORSION'
6079       include 'COMMON.VAR'
6080       include 'COMMON.GEO'
6081       include 'COMMON.FFIELD'
6082       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6083      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6084       logical lprn
6085       common /kutas/ lprn
6086 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6087 cd     & ' jj=',jj,' kk=',kk
6088 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6089       do iii=1,2
6090         do jjj=1,2
6091           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6092           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6093         enddo
6094       enddo
6095       call transpose2(aa1(1,1),aa1t(1,1))
6096       call transpose2(aa2(1,1),aa2t(1,1))
6097       do kkk=1,5
6098         do lll=1,3
6099           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6100      &      aa1tder(1,1,lll,kkk))
6101           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6102      &      aa2tder(1,1,lll,kkk))
6103         enddo
6104       enddo
6105       if (l.eq.j+1) then
6106 C parallel orientation of the two CA-CA-CA frames.
6107         if (i.gt.1) then
6108           iti=itortyp(itype(i))
6109         else
6110           iti=ntortyp+1
6111         endif
6112         itk1=itortyp(itype(k+1))
6113         itj=itortyp(itype(j))
6114         if (l.lt.nres-1) then
6115           itl1=itortyp(itype(l+1))
6116         else
6117           itl1=ntortyp+1
6118         endif
6119 C A1 kernel(j+1) A2T
6120 cd        do iii=1,2
6121 cd          write (iout,'(3f10.5,5x,3f10.5)')
6122 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6123 cd        enddo
6124         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6125      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6126      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6127 C Following matrices are needed only for 6-th order cumulants
6128         IF (wcorr6.gt.0.0d0) THEN
6129         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6130      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6131      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6132         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6133      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6134      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6135      &   ADtEAderx(1,1,1,1,1,1))
6136         lprn=.false.
6137         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6138      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6139      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6140      &   ADtEA1derx(1,1,1,1,1,1))
6141         ENDIF
6142 C End 6-th order cumulants
6143 cd        lprn=.false.
6144 cd        if (lprn) then
6145 cd        write (2,*) 'In calc_eello6'
6146 cd        do iii=1,2
6147 cd          write (2,*) 'iii=',iii
6148 cd          do kkk=1,5
6149 cd            write (2,*) 'kkk=',kkk
6150 cd            do jjj=1,2
6151 cd              write (2,'(3(2f10.5),5x)')
6152 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6153 cd            enddo
6154 cd          enddo
6155 cd        enddo
6156 cd        endif
6157         call transpose2(EUgder(1,1,k),auxmat(1,1))
6158         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6159         call transpose2(EUg(1,1,k),auxmat(1,1))
6160         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6161         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6162         do iii=1,2
6163           do kkk=1,5
6164             do lll=1,3
6165               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6166      &          EAEAderx(1,1,lll,kkk,iii,1))
6167             enddo
6168           enddo
6169         enddo
6170 C A1T kernel(i+1) A2
6171         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6172      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6173      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6174 C Following matrices are needed only for 6-th order cumulants
6175         IF (wcorr6.gt.0.0d0) THEN
6176         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6177      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6178      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6179         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6180      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6181      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6182      &   ADtEAderx(1,1,1,1,1,2))
6183         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6184      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6185      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6186      &   ADtEA1derx(1,1,1,1,1,2))
6187         ENDIF
6188 C End 6-th order cumulants
6189         call transpose2(EUgder(1,1,l),auxmat(1,1))
6190         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6191         call transpose2(EUg(1,1,l),auxmat(1,1))
6192         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6193         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6194         do iii=1,2
6195           do kkk=1,5
6196             do lll=1,3
6197               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6198      &          EAEAderx(1,1,lll,kkk,iii,2))
6199             enddo
6200           enddo
6201         enddo
6202 C AEAb1 and AEAb2
6203 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6204 C They are needed only when the fifth- or the sixth-order cumulants are
6205 C indluded.
6206         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6207         call transpose2(AEA(1,1,1),auxmat(1,1))
6208         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6209         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6210         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6211         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6212         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6213         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6214         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6215         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6216         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6217         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6218         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6219         call transpose2(AEA(1,1,2),auxmat(1,1))
6220         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6221         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6222         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6223         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6224         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6225         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6226         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6227         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6228         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6229         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6230         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6231 C Calculate the Cartesian derivatives of the vectors.
6232         do iii=1,2
6233           do kkk=1,5
6234             do lll=1,3
6235               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6236               call matvec2(auxmat(1,1),b1(1,iti),
6237      &          AEAb1derx(1,lll,kkk,iii,1,1))
6238               call matvec2(auxmat(1,1),Ub2(1,i),
6239      &          AEAb2derx(1,lll,kkk,iii,1,1))
6240               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6241      &          AEAb1derx(1,lll,kkk,iii,2,1))
6242               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6243      &          AEAb2derx(1,lll,kkk,iii,2,1))
6244               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6245               call matvec2(auxmat(1,1),b1(1,itj),
6246      &          AEAb1derx(1,lll,kkk,iii,1,2))
6247               call matvec2(auxmat(1,1),Ub2(1,j),
6248      &          AEAb2derx(1,lll,kkk,iii,1,2))
6249               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6250      &          AEAb1derx(1,lll,kkk,iii,2,2))
6251               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6252      &          AEAb2derx(1,lll,kkk,iii,2,2))
6253             enddo
6254           enddo
6255         enddo
6256         ENDIF
6257 C End vectors
6258       else
6259 C Antiparallel orientation of the two CA-CA-CA frames.
6260         if (i.gt.1) then
6261           iti=itortyp(itype(i))
6262         else
6263           iti=ntortyp+1
6264         endif
6265         itk1=itortyp(itype(k+1))
6266         itl=itortyp(itype(l))
6267         itj=itortyp(itype(j))
6268         if (j.lt.nres-1) then
6269           itj1=itortyp(itype(j+1))
6270         else
6271           itj1=ntortyp+1
6272         endif
6273 C A2 kernel(j-1)T A1T
6274         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6275      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6276      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6277 C Following matrices are needed only for 6-th order cumulants
6278         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6279      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6280         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6281      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6282      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6283         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6284      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6285      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6286      &   ADtEAderx(1,1,1,1,1,1))
6287         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6288      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6289      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6290      &   ADtEA1derx(1,1,1,1,1,1))
6291         ENDIF
6292 C End 6-th order cumulants
6293         call transpose2(EUgder(1,1,k),auxmat(1,1))
6294         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6295         call transpose2(EUg(1,1,k),auxmat(1,1))
6296         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6297         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6298         do iii=1,2
6299           do kkk=1,5
6300             do lll=1,3
6301               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6302      &          EAEAderx(1,1,lll,kkk,iii,1))
6303             enddo
6304           enddo
6305         enddo
6306 C A2T kernel(i+1)T A1
6307         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6308      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6309      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6310 C Following matrices are needed only for 6-th order cumulants
6311         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6312      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6313         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6314      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6315      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6316         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6317      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6318      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6319      &   ADtEAderx(1,1,1,1,1,2))
6320         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6321      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6322      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6323      &   ADtEA1derx(1,1,1,1,1,2))
6324         ENDIF
6325 C End 6-th order cumulants
6326         call transpose2(EUgder(1,1,j),auxmat(1,1))
6327         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6328         call transpose2(EUg(1,1,j),auxmat(1,1))
6329         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6330         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6331         do iii=1,2
6332           do kkk=1,5
6333             do lll=1,3
6334               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6335      &          EAEAderx(1,1,lll,kkk,iii,2))
6336             enddo
6337           enddo
6338         enddo
6339 C AEAb1 and AEAb2
6340 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6341 C They are needed only when the fifth- or the sixth-order cumulants are
6342 C indluded.
6343         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6344      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6345         call transpose2(AEA(1,1,1),auxmat(1,1))
6346         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6347         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6348         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6349         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6350         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6351         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6352         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6353         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6354         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6355         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6356         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6357         call transpose2(AEA(1,1,2),auxmat(1,1))
6358         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6359         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6360         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6361         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6362         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6363         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6364         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6365         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6366         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6367         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6368         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6369 C Calculate the Cartesian derivatives of the vectors.
6370         do iii=1,2
6371           do kkk=1,5
6372             do lll=1,3
6373               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6374               call matvec2(auxmat(1,1),b1(1,iti),
6375      &          AEAb1derx(1,lll,kkk,iii,1,1))
6376               call matvec2(auxmat(1,1),Ub2(1,i),
6377      &          AEAb2derx(1,lll,kkk,iii,1,1))
6378               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6379      &          AEAb1derx(1,lll,kkk,iii,2,1))
6380               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6381      &          AEAb2derx(1,lll,kkk,iii,2,1))
6382               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6383               call matvec2(auxmat(1,1),b1(1,itl),
6384      &          AEAb1derx(1,lll,kkk,iii,1,2))
6385               call matvec2(auxmat(1,1),Ub2(1,l),
6386      &          AEAb2derx(1,lll,kkk,iii,1,2))
6387               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6388      &          AEAb1derx(1,lll,kkk,iii,2,2))
6389               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6390      &          AEAb2derx(1,lll,kkk,iii,2,2))
6391             enddo
6392           enddo
6393         enddo
6394         ENDIF
6395 C End vectors
6396       endif
6397       return
6398       end
6399 C---------------------------------------------------------------------------
6400       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6401      &  KK,KKderg,AKA,AKAderg,AKAderx)
6402       implicit none
6403       integer nderg
6404       logical transp
6405       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6406      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6407      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6408       integer iii,kkk,lll
6409       integer jjj,mmm
6410       logical lprn
6411       common /kutas/ lprn
6412       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6413       do iii=1,nderg
6414         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6415      &    AKAderg(1,1,iii))
6416       enddo
6417 cd      if (lprn) write (2,*) 'In kernel'
6418       do kkk=1,5
6419 cd        if (lprn) write (2,*) 'kkk=',kkk
6420         do lll=1,3
6421           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6422      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6423 cd          if (lprn) then
6424 cd            write (2,*) 'lll=',lll
6425 cd            write (2,*) 'iii=1'
6426 cd            do jjj=1,2
6427 cd              write (2,'(3(2f10.5),5x)')
6428 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6429 cd            enddo
6430 cd          endif
6431           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6432      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6433 cd          if (lprn) then
6434 cd            write (2,*) 'lll=',lll
6435 cd            write (2,*) 'iii=2'
6436 cd            do jjj=1,2
6437 cd              write (2,'(3(2f10.5),5x)')
6438 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6439 cd            enddo
6440 cd          endif
6441         enddo
6442       enddo
6443       return
6444       end
6445 C---------------------------------------------------------------------------
6446       double precision function eello4(i,j,k,l,jj,kk)
6447       implicit real*8 (a-h,o-z)
6448       include 'DIMENSIONS'
6449       include 'COMMON.IOUNITS'
6450       include 'COMMON.CHAIN'
6451       include 'COMMON.DERIV'
6452       include 'COMMON.INTERACT'
6453       include 'COMMON.CONTACTS'
6454       include 'COMMON.TORSION'
6455       include 'COMMON.VAR'
6456       include 'COMMON.GEO'
6457       double precision pizda(2,2),ggg1(3),ggg2(3)
6458 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6459 cd        eello4=0.0d0
6460 cd        return
6461 cd      endif
6462 cd      print *,'eello4:',i,j,k,l,jj,kk
6463 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6464 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6465 cold      eij=facont_hb(jj,i)
6466 cold      ekl=facont_hb(kk,k)
6467 cold      ekont=eij*ekl
6468       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6469 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6470       gcorr_loc(k-1)=gcorr_loc(k-1)
6471      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6472       if (l.eq.j+1) then
6473         gcorr_loc(l-1)=gcorr_loc(l-1)
6474      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6475       else
6476         gcorr_loc(j-1)=gcorr_loc(j-1)
6477      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6478       endif
6479       do iii=1,2
6480         do kkk=1,5
6481           do lll=1,3
6482             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6483      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6484 cd            derx(lll,kkk,iii)=0.0d0
6485           enddo
6486         enddo
6487       enddo
6488 cd      gcorr_loc(l-1)=0.0d0
6489 cd      gcorr_loc(j-1)=0.0d0
6490 cd      gcorr_loc(k-1)=0.0d0
6491 cd      eel4=1.0d0
6492 cd      write (iout,*)'Contacts have occurred for peptide groups',
6493 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6494 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6495       if (j.lt.nres-1) then
6496         j1=j+1
6497         j2=j-1
6498       else
6499         j1=j-1
6500         j2=j-2
6501       endif
6502       if (l.lt.nres-1) then
6503         l1=l+1
6504         l2=l-1
6505       else
6506         l1=l-1
6507         l2=l-2
6508       endif
6509       do ll=1,3
6510 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6511         ggg1(ll)=eel4*g_contij(ll,1)
6512         ggg2(ll)=eel4*g_contij(ll,2)
6513         ghalf=0.5d0*ggg1(ll)
6514 cd        ghalf=0.0d0
6515         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6516         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6517         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6518         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6519 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6520         ghalf=0.5d0*ggg2(ll)
6521 cd        ghalf=0.0d0
6522         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6523         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6524         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6525         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6526       enddo
6527 cd      goto 1112
6528       do m=i+1,j-1
6529         do ll=1,3
6530 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6531           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6532         enddo
6533       enddo
6534       do m=k+1,l-1
6535         do ll=1,3
6536 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6537           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6538         enddo
6539       enddo
6540 1112  continue
6541       do m=i+2,j2
6542         do ll=1,3
6543           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6544         enddo
6545       enddo
6546       do m=k+2,l2
6547         do ll=1,3
6548           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6549         enddo
6550       enddo
6551 cd      do iii=1,nres-3
6552 cd        write (2,*) iii,gcorr_loc(iii)
6553 cd      enddo
6554       eello4=ekont*eel4
6555 cd      write (2,*) 'ekont',ekont
6556 cd      write (iout,*) 'eello4',ekont*eel4
6557       return
6558       end
6559 C---------------------------------------------------------------------------
6560       double precision function eello5(i,j,k,l,jj,kk)
6561       implicit real*8 (a-h,o-z)
6562       include 'DIMENSIONS'
6563       include 'COMMON.IOUNITS'
6564       include 'COMMON.CHAIN'
6565       include 'COMMON.DERIV'
6566       include 'COMMON.INTERACT'
6567       include 'COMMON.CONTACTS'
6568       include 'COMMON.TORSION'
6569       include 'COMMON.VAR'
6570       include 'COMMON.GEO'
6571       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6572       double precision ggg1(3),ggg2(3)
6573 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6574 C                                                                              C
6575 C                            Parallel chains                                   C
6576 C                                                                              C
6577 C          o             o                   o             o                   C
6578 C         /l\           / \             \   / \           / \   /              C
6579 C        /   \         /   \             \ /   \         /   \ /               C
6580 C       j| o |l1       | o |              o| o |         | o |o                C
6581 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6582 C      \i/   \         /   \ /             /   \         /   \                 C
6583 C       o    k1             o                                                  C
6584 C         (I)          (II)                (III)          (IV)                 C
6585 C                                                                              C
6586 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6587 C                                                                              C
6588 C                            Antiparallel chains                               C
6589 C                                                                              C
6590 C          o             o                   o             o                   C
6591 C         /j\           / \             \   / \           / \   /              C
6592 C        /   \         /   \             \ /   \         /   \ /               C
6593 C      j1| o |l        | o |              o| o |         | o |o                C
6594 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6595 C      \i/   \         /   \ /             /   \         /   \                 C
6596 C       o     k1            o                                                  C
6597 C         (I)          (II)                (III)          (IV)                 C
6598 C                                                                              C
6599 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6600 C                                                                              C
6601 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6602 C                                                                              C
6603 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6604 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6605 cd        eello5=0.0d0
6606 cd        return
6607 cd      endif
6608 cd      write (iout,*)
6609 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6610 cd     &   ' and',k,l
6611       itk=itortyp(itype(k))
6612       itl=itortyp(itype(l))
6613       itj=itortyp(itype(j))
6614       eello5_1=0.0d0
6615       eello5_2=0.0d0
6616       eello5_3=0.0d0
6617       eello5_4=0.0d0
6618 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6619 cd     &   eel5_3_num,eel5_4_num)
6620       do iii=1,2
6621         do kkk=1,5
6622           do lll=1,3
6623             derx(lll,kkk,iii)=0.0d0
6624           enddo
6625         enddo
6626       enddo
6627 cd      eij=facont_hb(jj,i)
6628 cd      ekl=facont_hb(kk,k)
6629 cd      ekont=eij*ekl
6630 cd      write (iout,*)'Contacts have occurred for peptide groups',
6631 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6632 cd      goto 1111
6633 C Contribution from the graph I.
6634 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
6635 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
6636       call transpose2(EUg(1,1,k),auxmat(1,1))
6637       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
6638       vv(1)=pizda(1,1)-pizda(2,2)
6639       vv(2)=pizda(1,2)+pizda(2,1)
6640       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
6641      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6642 C Explicit gradient in virtual-dihedral angles.
6643       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
6644      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
6645      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
6646       call transpose2(EUgder(1,1,k),auxmat1(1,1))
6647       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
6648       vv(1)=pizda(1,1)-pizda(2,2)
6649       vv(2)=pizda(1,2)+pizda(2,1)
6650       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6651      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
6652      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6653       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
6654       vv(1)=pizda(1,1)-pizda(2,2)
6655       vv(2)=pizda(1,2)+pizda(2,1)
6656       if (l.eq.j+1) then
6657         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
6658      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6659      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6660       else
6661         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
6662      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
6663      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
6664       endif
6665 C Cartesian gradient
6666       do iii=1,2
6667         do kkk=1,5
6668           do lll=1,3
6669             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
6670      &        pizda(1,1))
6671             vv(1)=pizda(1,1)-pizda(2,2)
6672             vv(2)=pizda(1,2)+pizda(2,1)
6673             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6674      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
6675      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
6676           enddo
6677         enddo
6678       enddo
6679 c      goto 1112
6680 c1111  continue
6681 C Contribution from graph II
6682       call transpose2(EE(1,1,itk),auxmat(1,1))
6683       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
6684       vv(1)=pizda(1,1)+pizda(2,2)
6685       vv(2)=pizda(2,1)-pizda(1,2)
6686       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
6687      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
6688 C Explicit gradient in virtual-dihedral angles.
6689       g_corr5_loc(k-1)=g_corr5_loc(k-1)
6690      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
6691       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
6692       vv(1)=pizda(1,1)+pizda(2,2)
6693       vv(2)=pizda(2,1)-pizda(1,2)
6694       if (l.eq.j+1) then
6695         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6696      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6697      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6698       else
6699         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6700      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
6701      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
6702       endif
6703 C Cartesian gradient
6704       do iii=1,2
6705         do kkk=1,5
6706           do lll=1,3
6707             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6708      &        pizda(1,1))
6709             vv(1)=pizda(1,1)+pizda(2,2)
6710             vv(2)=pizda(2,1)-pizda(1,2)
6711             derx(lll,kkk,iii)=derx(lll,kkk,iii)
6712      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
6713      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
6714           enddo
6715         enddo
6716       enddo
6717 cd      goto 1112
6718 cd1111  continue
6719       if (l.eq.j+1) then
6720 cd        goto 1110
6721 C Parallel orientation
6722 C Contribution from graph III
6723         call transpose2(EUg(1,1,l),auxmat(1,1))
6724         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6725         vv(1)=pizda(1,1)-pizda(2,2)
6726         vv(2)=pizda(1,2)+pizda(2,1)
6727         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
6728      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6729 C Explicit gradient in virtual-dihedral angles.
6730         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6731      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
6732      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
6733         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6734         vv(1)=pizda(1,1)-pizda(2,2)
6735         vv(2)=pizda(1,2)+pizda(2,1)
6736         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6737      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
6738      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6739         call transpose2(EUgder(1,1,l),auxmat1(1,1))
6740         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6741         vv(1)=pizda(1,1)-pizda(2,2)
6742         vv(2)=pizda(1,2)+pizda(2,1)
6743         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6744      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
6745      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
6746 C Cartesian gradient
6747         do iii=1,2
6748           do kkk=1,5
6749             do lll=1,3
6750               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6751      &          pizda(1,1))
6752               vv(1)=pizda(1,1)-pizda(2,2)
6753               vv(2)=pizda(1,2)+pizda(2,1)
6754               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6755      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
6756      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
6757             enddo
6758           enddo
6759         enddo
6760 cd        goto 1112
6761 C Contribution from graph IV
6762 cd1110    continue
6763         call transpose2(EE(1,1,itl),auxmat(1,1))
6764         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6765         vv(1)=pizda(1,1)+pizda(2,2)
6766         vv(2)=pizda(2,1)-pizda(1,2)
6767         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
6768      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
6769 C Explicit gradient in virtual-dihedral angles.
6770         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6771      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
6772         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6773         vv(1)=pizda(1,1)+pizda(2,2)
6774         vv(2)=pizda(2,1)-pizda(1,2)
6775         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6776      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
6777      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
6778 C Cartesian gradient
6779         do iii=1,2
6780           do kkk=1,5
6781             do lll=1,3
6782               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6783      &          pizda(1,1))
6784               vv(1)=pizda(1,1)+pizda(2,2)
6785               vv(2)=pizda(2,1)-pizda(1,2)
6786               derx(lll,kkk,iii)=derx(lll,kkk,iii)
6787      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
6788      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
6789             enddo
6790           enddo
6791         enddo
6792       else
6793 C Antiparallel orientation
6794 C Contribution from graph III
6795 c        goto 1110
6796         call transpose2(EUg(1,1,j),auxmat(1,1))
6797         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
6798         vv(1)=pizda(1,1)-pizda(2,2)
6799         vv(2)=pizda(1,2)+pizda(2,1)
6800         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
6801      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6802 C Explicit gradient in virtual-dihedral angles.
6803         g_corr5_loc(l-1)=g_corr5_loc(l-1)
6804      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
6805      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
6806         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
6807         vv(1)=pizda(1,1)-pizda(2,2)
6808         vv(2)=pizda(1,2)+pizda(2,1)
6809         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6810      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
6811      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6812         call transpose2(EUgder(1,1,j),auxmat1(1,1))
6813         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
6814         vv(1)=pizda(1,1)-pizda(2,2)
6815         vv(2)=pizda(1,2)+pizda(2,1)
6816         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6817      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
6818      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
6819 C Cartesian gradient
6820         do iii=1,2
6821           do kkk=1,5
6822             do lll=1,3
6823               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
6824      &          pizda(1,1))
6825               vv(1)=pizda(1,1)-pizda(2,2)
6826               vv(2)=pizda(1,2)+pizda(2,1)
6827               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6828      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
6829      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
6830             enddo
6831           enddo
6832         enddo
6833 cd        goto 1112
6834 C Contribution from graph IV
6835 1110    continue
6836         call transpose2(EE(1,1,itj),auxmat(1,1))
6837         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
6838         vv(1)=pizda(1,1)+pizda(2,2)
6839         vv(2)=pizda(2,1)-pizda(1,2)
6840         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
6841      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
6842 C Explicit gradient in virtual-dihedral angles.
6843         g_corr5_loc(j-1)=g_corr5_loc(j-1)
6844      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
6845         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
6846         vv(1)=pizda(1,1)+pizda(2,2)
6847         vv(2)=pizda(2,1)-pizda(1,2)
6848         g_corr5_loc(k-1)=g_corr5_loc(k-1)
6849      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
6850      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
6851 C Cartesian gradient
6852         do iii=1,2
6853           do kkk=1,5
6854             do lll=1,3
6855               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6856      &          pizda(1,1))
6857               vv(1)=pizda(1,1)+pizda(2,2)
6858               vv(2)=pizda(2,1)-pizda(1,2)
6859               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
6860      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
6861      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
6862             enddo
6863           enddo
6864         enddo
6865       endif
6866 1112  continue
6867       eel5=eello5_1+eello5_2+eello5_3+eello5_4
6868 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
6869 cd        write (2,*) 'ijkl',i,j,k,l
6870 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
6871 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
6872 cd      endif
6873 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
6874 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
6875 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
6876 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
6877       if (j.lt.nres-1) then
6878         j1=j+1
6879         j2=j-1
6880       else
6881         j1=j-1
6882         j2=j-2
6883       endif
6884       if (l.lt.nres-1) then
6885         l1=l+1
6886         l2=l-1
6887       else
6888         l1=l-1
6889         l2=l-2
6890       endif
6891 cd      eij=1.0d0
6892 cd      ekl=1.0d0
6893 cd      ekont=1.0d0
6894 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
6895       do ll=1,3
6896         ggg1(ll)=eel5*g_contij(ll,1)
6897         ggg2(ll)=eel5*g_contij(ll,2)
6898 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
6899         ghalf=0.5d0*ggg1(ll)
6900 cd        ghalf=0.0d0
6901         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
6902         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
6903         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
6904         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
6905 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
6906         ghalf=0.5d0*ggg2(ll)
6907 cd        ghalf=0.0d0
6908         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
6909         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
6910         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
6911         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
6912       enddo
6913 cd      goto 1112
6914       do m=i+1,j-1
6915         do ll=1,3
6916 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
6917           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
6918         enddo
6919       enddo
6920       do m=k+1,l-1
6921         do ll=1,3
6922 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
6923           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
6924         enddo
6925       enddo
6926 c1112  continue
6927       do m=i+2,j2
6928         do ll=1,3
6929           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
6930         enddo
6931       enddo
6932       do m=k+2,l2
6933         do ll=1,3
6934           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
6935         enddo
6936       enddo
6937 cd      do iii=1,nres-3
6938 cd        write (2,*) iii,g_corr5_loc(iii)
6939 cd      enddo
6940       eello5=ekont*eel5
6941 cd      write (2,*) 'ekont',ekont
6942 cd      write (iout,*) 'eello5',ekont*eel5
6943       return
6944       end
6945 c--------------------------------------------------------------------------
6946       double precision function eello6(i,j,k,l,jj,kk)
6947       implicit real*8 (a-h,o-z)
6948       include 'DIMENSIONS'
6949       include 'COMMON.IOUNITS'
6950       include 'COMMON.CHAIN'
6951       include 'COMMON.DERIV'
6952       include 'COMMON.INTERACT'
6953       include 'COMMON.CONTACTS'
6954       include 'COMMON.TORSION'
6955       include 'COMMON.VAR'
6956       include 'COMMON.GEO'
6957       include 'COMMON.FFIELD'
6958       double precision ggg1(3),ggg2(3)
6959 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
6960 cd        eello6=0.0d0
6961 cd        return
6962 cd      endif
6963 cd      write (iout,*)
6964 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
6965 cd     &   ' and',k,l
6966       eello6_1=0.0d0
6967       eello6_2=0.0d0
6968       eello6_3=0.0d0
6969       eello6_4=0.0d0
6970       eello6_5=0.0d0
6971       eello6_6=0.0d0
6972 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
6973 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
6974       do iii=1,2
6975         do kkk=1,5
6976           do lll=1,3
6977             derx(lll,kkk,iii)=0.0d0
6978           enddo
6979         enddo
6980       enddo
6981 cd      eij=facont_hb(jj,i)
6982 cd      ekl=facont_hb(kk,k)
6983 cd      ekont=eij*ekl
6984 cd      eij=1.0d0
6985 cd      ekl=1.0d0
6986 cd      ekont=1.0d0
6987       if (l.eq.j+1) then
6988         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6989         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
6990         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
6991         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6992         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
6993         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
6994       else
6995         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
6996         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
6997         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
6998         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
6999         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7000           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7001         else
7002           eello6_5=0.0d0
7003         endif
7004         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7005       endif
7006 C If turn contributions are considered, they will be handled separately.
7007       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7008 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7009 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7010 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7011 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7012 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7013 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7014 cd      goto 1112
7015       if (j.lt.nres-1) then
7016         j1=j+1
7017         j2=j-1
7018       else
7019         j1=j-1
7020         j2=j-2
7021       endif
7022       if (l.lt.nres-1) then
7023         l1=l+1
7024         l2=l-1
7025       else
7026         l1=l-1
7027         l2=l-2
7028       endif
7029       do ll=1,3
7030         ggg1(ll)=eel6*g_contij(ll,1)
7031         ggg2(ll)=eel6*g_contij(ll,2)
7032 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7033         ghalf=0.5d0*ggg1(ll)
7034 cd        ghalf=0.0d0
7035         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7036         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7037         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7038         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7039         ghalf=0.5d0*ggg2(ll)
7040 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7041 cd        ghalf=0.0d0
7042         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7043         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7044         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7045         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7046       enddo
7047 cd      goto 1112
7048       do m=i+1,j-1
7049         do ll=1,3
7050 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7051           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7052         enddo
7053       enddo
7054       do m=k+1,l-1
7055         do ll=1,3
7056 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7057           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7058         enddo
7059       enddo
7060 1112  continue
7061       do m=i+2,j2
7062         do ll=1,3
7063           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7064         enddo
7065       enddo
7066       do m=k+2,l2
7067         do ll=1,3
7068           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7069         enddo
7070       enddo
7071 cd      do iii=1,nres-3
7072 cd        write (2,*) iii,g_corr6_loc(iii)
7073 cd      enddo
7074       eello6=ekont*eel6
7075 cd      write (2,*) 'ekont',ekont
7076 cd      write (iout,*) 'eello6',ekont*eel6
7077       return
7078       end
7079 c--------------------------------------------------------------------------
7080       double precision function eello6_graph1(i,j,k,l,imat,swap)
7081       implicit real*8 (a-h,o-z)
7082       include 'DIMENSIONS'
7083       include 'COMMON.IOUNITS'
7084       include 'COMMON.CHAIN'
7085       include 'COMMON.DERIV'
7086       include 'COMMON.INTERACT'
7087       include 'COMMON.CONTACTS'
7088       include 'COMMON.TORSION'
7089       include 'COMMON.VAR'
7090       include 'COMMON.GEO'
7091       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7092       logical swap
7093       logical lprn
7094       common /kutas/ lprn
7095 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7096 C
7097 C      Parallel       Antiparallel
7098 C
7099 C          o             o
7100 C         /l\           /j\
7101 C        /   \         /   \
7102 C       /| o |         | o |\
7103 C     \ j|/k\|  /   \  |/k\|l /
7104 C      \ /   \ /     \ /   \ /
7105 C       o     o       o     o
7106 C       i             i
7107 C
7108 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7109       itk=itortyp(itype(k))
7110       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7111       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7112       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7113       call transpose2(EUgC(1,1,k),auxmat(1,1))
7114       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7115       vv1(1)=pizda1(1,1)-pizda1(2,2)
7116       vv1(2)=pizda1(1,2)+pizda1(2,1)
7117       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7118       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7119       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7120       s5=scalar2(vv(1),Dtobr2(1,i))
7121 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7122       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7123       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7124      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7125      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7126      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7127      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7128      & +scalar2(vv(1),Dtobr2der(1,i)))
7129       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7130       vv1(1)=pizda1(1,1)-pizda1(2,2)
7131       vv1(2)=pizda1(1,2)+pizda1(2,1)
7132       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7133       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7134       if (l.eq.j+1) then
7135         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7136      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7137      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7138      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7139      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7140       else
7141         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7142      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7143      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7144      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7145      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7146       endif
7147       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7148       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7149       vv1(1)=pizda1(1,1)-pizda1(2,2)
7150       vv1(2)=pizda1(1,2)+pizda1(2,1)
7151       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7152      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7153      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7154      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7155       do iii=1,2
7156         if (swap) then
7157           ind=3-iii
7158         else
7159           ind=iii
7160         endif
7161         do kkk=1,5
7162           do lll=1,3
7163             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7164             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7165             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7166             call transpose2(EUgC(1,1,k),auxmat(1,1))
7167             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7168      &        pizda1(1,1))
7169             vv1(1)=pizda1(1,1)-pizda1(2,2)
7170             vv1(2)=pizda1(1,2)+pizda1(2,1)
7171             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7172             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7173      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7174             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7175      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7176             s5=scalar2(vv(1),Dtobr2(1,i))
7177             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7178           enddo
7179         enddo
7180       enddo
7181       return
7182       end
7183 c----------------------------------------------------------------------------
7184       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7185       implicit real*8 (a-h,o-z)
7186       include 'DIMENSIONS'
7187       include 'COMMON.IOUNITS'
7188       include 'COMMON.CHAIN'
7189       include 'COMMON.DERIV'
7190       include 'COMMON.INTERACT'
7191       include 'COMMON.CONTACTS'
7192       include 'COMMON.TORSION'
7193       include 'COMMON.VAR'
7194       include 'COMMON.GEO'
7195       logical swap
7196       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7197      & auxvec1(2),auxvec2(1),auxmat1(2,2)
7198       logical lprn
7199       common /kutas/ lprn
7200 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7201 C
7202 C      Parallel       Antiparallel
7203 C
7204 C          o             o
7205 C     \   /l\           /j\   /
7206 C      \ /   \         /   \ /
7207 C       o| o |         | o |o
7208 C     \ j|/k\|      \  |/k\|l
7209 C      \ /   \       \ /   \
7210 C       o             o
7211 C       i             i
7212 C
7213 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7214 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7215 C AL 7/4/01 s1 would occur in the sixth-order moment,
7216 C           but not in a cluster cumulant
7217 #ifdef MOMENT
7218       s1=dip(1,jj,i)*dip(1,kk,k)
7219 #endif
7220       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7221       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7222       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7223       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7224       call transpose2(EUg(1,1,k),auxmat(1,1))
7225       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7226       vv(1)=pizda(1,1)-pizda(2,2)
7227       vv(2)=pizda(1,2)+pizda(2,1)
7228       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7229 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7230 #ifdef MOMENT
7231       eello6_graph2=-(s1+s2+s3+s4)
7232 #else
7233       eello6_graph2=-(s2+s3+s4)
7234 #endif
7235 c      eello6_graph2=-s3
7236 C Derivatives in gamma(i-1)
7237       if (i.gt.1) then
7238 #ifdef MOMENT
7239         s1=dipderg(1,jj,i)*dip(1,kk,k)
7240 #endif
7241         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7242         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7243         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7244         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7245 #ifdef MOMENT
7246         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7247 #else
7248         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7249 #endif
7250 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7251       endif
7252 C Derivatives in gamma(k-1)
7253 #ifdef MOMENT
7254       s1=dip(1,jj,i)*dipderg(1,kk,k)
7255 #endif
7256       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7257       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7258       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7259       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7260       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7261       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7262       vv(1)=pizda(1,1)-pizda(2,2)
7263       vv(2)=pizda(1,2)+pizda(2,1)
7264       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7265 #ifdef MOMENT
7266       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7267 #else
7268       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7269 #endif
7270 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7271 C Derivatives in gamma(j-1) or gamma(l-1)
7272       if (j.gt.1) then
7273 #ifdef MOMENT
7274         s1=dipderg(3,jj,i)*dip(1,kk,k)
7275 #endif
7276         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7277         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7278         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7279         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7280         vv(1)=pizda(1,1)-pizda(2,2)
7281         vv(2)=pizda(1,2)+pizda(2,1)
7282         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7283 #ifdef MOMENT
7284         if (swap) then
7285           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7286         else
7287           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7288         endif
7289 #endif
7290         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7291 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7292       endif
7293 C Derivatives in gamma(l-1) or gamma(j-1)
7294       if (l.gt.1) then
7295 #ifdef MOMENT
7296         s1=dip(1,jj,i)*dipderg(3,kk,k)
7297 #endif
7298         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7299         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7300         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7301         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7302         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7303         vv(1)=pizda(1,1)-pizda(2,2)
7304         vv(2)=pizda(1,2)+pizda(2,1)
7305         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7306 #ifdef MOMENT
7307         if (swap) then
7308           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7309         else
7310           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7311         endif
7312 #endif
7313         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7314 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7315       endif
7316 C Cartesian derivatives.
7317       if (lprn) then
7318         write (2,*) 'In eello6_graph2'
7319         do iii=1,2
7320           write (2,*) 'iii=',iii
7321           do kkk=1,5
7322             write (2,*) 'kkk=',kkk
7323             do jjj=1,2
7324               write (2,'(3(2f10.5),5x)')
7325      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7326             enddo
7327           enddo
7328         enddo
7329       endif
7330       do iii=1,2
7331         do kkk=1,5
7332           do lll=1,3
7333 #ifdef MOMENT
7334             if (iii.eq.1) then
7335               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7336             else
7337               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7338             endif
7339 #endif
7340             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7341      &        auxvec(1))
7342             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7343             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7344      &        auxvec(1))
7345             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7346             call transpose2(EUg(1,1,k),auxmat(1,1))
7347             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7348      &        pizda(1,1))
7349             vv(1)=pizda(1,1)-pizda(2,2)
7350             vv(2)=pizda(1,2)+pizda(2,1)
7351             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7352 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7353 #ifdef MOMENT
7354             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7355 #else
7356             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7357 #endif
7358             if (swap) then
7359               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7360             else
7361               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7362             endif
7363           enddo
7364         enddo
7365       enddo
7366       return
7367       end
7368 c----------------------------------------------------------------------------
7369       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7370       implicit real*8 (a-h,o-z)
7371       include 'DIMENSIONS'
7372       include 'COMMON.IOUNITS'
7373       include 'COMMON.CHAIN'
7374       include 'COMMON.DERIV'
7375       include 'COMMON.INTERACT'
7376       include 'COMMON.CONTACTS'
7377       include 'COMMON.TORSION'
7378       include 'COMMON.VAR'
7379       include 'COMMON.GEO'
7380       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7381       logical swap
7382 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7383 C
7384 C      Parallel       Antiparallel
7385 C
7386 C          o             o
7387 C         /l\   /   \   /j\
7388 C        /   \ /     \ /   \
7389 C       /| o |o       o| o |\
7390 C       j|/k\|  /      |/k\|l /
7391 C        /   \ /       /   \ /
7392 C       /     o       /     o
7393 C       i             i
7394 C
7395 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7396 C
7397 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7398 C           energy moment and not to the cluster cumulant.
7399       iti=itortyp(itype(i))
7400       if (j.lt.nres-1) then
7401         itj1=itortyp(itype(j+1))
7402       else
7403         itj1=ntortyp+1
7404       endif
7405       itk=itortyp(itype(k))
7406       itk1=itortyp(itype(k+1))
7407       if (l.lt.nres-1) then
7408         itl1=itortyp(itype(l+1))
7409       else
7410         itl1=ntortyp+1
7411       endif
7412 #ifdef MOMENT
7413       s1=dip(4,jj,i)*dip(4,kk,k)
7414 #endif
7415       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7416       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7417       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7418       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7419       call transpose2(EE(1,1,itk),auxmat(1,1))
7420       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7421       vv(1)=pizda(1,1)+pizda(2,2)
7422       vv(2)=pizda(2,1)-pizda(1,2)
7423       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7424 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7425 #ifdef MOMENT
7426       eello6_graph3=-(s1+s2+s3+s4)
7427 #else
7428       eello6_graph3=-(s2+s3+s4)
7429 #endif
7430 c      eello6_graph3=-s4
7431 C Derivatives in gamma(k-1)
7432       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7433       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7434       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7435       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7436 C Derivatives in gamma(l-1)
7437       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7438       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7439       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7440       vv(1)=pizda(1,1)+pizda(2,2)
7441       vv(2)=pizda(2,1)-pizda(1,2)
7442       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7443       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7444 C Cartesian derivatives.
7445       do iii=1,2
7446         do kkk=1,5
7447           do lll=1,3
7448 #ifdef MOMENT
7449             if (iii.eq.1) then
7450               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7451             else
7452               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7453             endif
7454 #endif
7455             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7456      &        auxvec(1))
7457             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7458             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7459      &        auxvec(1))
7460             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7461             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7462      &        pizda(1,1))
7463             vv(1)=pizda(1,1)+pizda(2,2)
7464             vv(2)=pizda(2,1)-pizda(1,2)
7465             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7466 #ifdef MOMENT
7467             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7468 #else
7469             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7470 #endif
7471             if (swap) then
7472               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7473             else
7474               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7475             endif
7476 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7477           enddo
7478         enddo
7479       enddo
7480       return
7481       end
7482 c----------------------------------------------------------------------------
7483       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7484       implicit real*8 (a-h,o-z)
7485       include 'DIMENSIONS'
7486       include 'COMMON.IOUNITS'
7487       include 'COMMON.CHAIN'
7488       include 'COMMON.DERIV'
7489       include 'COMMON.INTERACT'
7490       include 'COMMON.CONTACTS'
7491       include 'COMMON.TORSION'
7492       include 'COMMON.VAR'
7493       include 'COMMON.GEO'
7494       include 'COMMON.FFIELD'
7495       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7496      & auxvec1(2),auxmat1(2,2)
7497       logical swap
7498 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7499 C
7500 C      Parallel       Antiparallel
7501 C
7502 C          o             o
7503 C         /l\   /   \   /j\
7504 C        /   \ /     \ /   \
7505 C       /| o |o       o| o |\
7506 C     \ j|/k\|      \  |/k\|l
7507 C      \ /   \       \ /   \
7508 C       o     \       o     \
7509 C       i             i
7510 C
7511 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7512 C
7513 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7514 C           energy moment and not to the cluster cumulant.
7515 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7516       iti=itortyp(itype(i))
7517       itj=itortyp(itype(j))
7518       if (j.lt.nres-1) then
7519         itj1=itortyp(itype(j+1))
7520       else
7521         itj1=ntortyp+1
7522       endif
7523       itk=itortyp(itype(k))
7524       if (k.lt.nres-1) then
7525         itk1=itortyp(itype(k+1))
7526       else
7527         itk1=ntortyp+1
7528       endif
7529       itl=itortyp(itype(l))
7530       if (l.lt.nres-1) then
7531         itl1=itortyp(itype(l+1))
7532       else
7533         itl1=ntortyp+1
7534       endif
7535 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7536 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7537 cd     & ' itl',itl,' itl1',itl1
7538 #ifdef MOMENT
7539       if (imat.eq.1) then
7540         s1=dip(3,jj,i)*dip(3,kk,k)
7541       else
7542         s1=dip(2,jj,j)*dip(2,kk,l)
7543       endif
7544 #endif
7545       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7546       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7547       if (j.eq.l+1) then
7548         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7549         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7550       else
7551         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7552         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7553       endif
7554       call transpose2(EUg(1,1,k),auxmat(1,1))
7555       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7556       vv(1)=pizda(1,1)-pizda(2,2)
7557       vv(2)=pizda(2,1)+pizda(1,2)
7558       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7559 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7560 #ifdef MOMENT
7561       eello6_graph4=-(s1+s2+s3+s4)
7562 #else
7563       eello6_graph4=-(s2+s3+s4)
7564 #endif
7565 C Derivatives in gamma(i-1)
7566       if (i.gt.1) then
7567 #ifdef MOMENT
7568         if (imat.eq.1) then
7569           s1=dipderg(2,jj,i)*dip(3,kk,k)
7570         else
7571           s1=dipderg(4,jj,j)*dip(2,kk,l)
7572         endif
7573 #endif
7574         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7575         if (j.eq.l+1) then
7576           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7577           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7578         else
7579           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7580           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7581         endif
7582         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7583         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7584 cd          write (2,*) 'turn6 derivatives'
7585 #ifdef MOMENT
7586           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7587 #else
7588           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7589 #endif
7590         else
7591 #ifdef MOMENT
7592           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7593 #else
7594           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7595 #endif
7596         endif
7597       endif
7598 C Derivatives in gamma(k-1)
7599 #ifdef MOMENT
7600       if (imat.eq.1) then
7601         s1=dip(3,jj,i)*dipderg(2,kk,k)
7602       else
7603         s1=dip(2,jj,j)*dipderg(4,kk,l)
7604       endif
7605 #endif
7606       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7607       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7608       if (j.eq.l+1) then
7609         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
7610         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7611       else
7612         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
7613         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7614       endif
7615       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7616       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
7617       vv(1)=pizda(1,1)-pizda(2,2)
7618       vv(2)=pizda(2,1)+pizda(1,2)
7619       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7620       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7621 #ifdef MOMENT
7622         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
7623 #else
7624         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
7625 #endif
7626       else
7627 #ifdef MOMENT
7628         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7629 #else
7630         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7631 #endif
7632       endif
7633 C Derivatives in gamma(j-1) or gamma(l-1)
7634       if (l.eq.j+1 .and. l.gt.1) then
7635         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7636         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7637         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7638         vv(1)=pizda(1,1)-pizda(2,2)
7639         vv(2)=pizda(2,1)+pizda(1,2)
7640         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7641         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7642       else if (j.gt.1) then
7643         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
7644         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7645         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
7646         vv(1)=pizda(1,1)-pizda(2,2)
7647         vv(2)=pizda(2,1)+pizda(1,2)
7648         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7649         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7650           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
7651         else
7652           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
7653         endif
7654       endif
7655 C Cartesian derivatives.
7656       do iii=1,2
7657         do kkk=1,5
7658           do lll=1,3
7659 #ifdef MOMENT
7660             if (iii.eq.1) then
7661               if (imat.eq.1) then
7662                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
7663               else
7664                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
7665               endif
7666             else
7667               if (imat.eq.1) then
7668                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
7669               else
7670                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
7671               endif
7672             endif
7673 #endif
7674             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
7675      &        auxvec(1))
7676             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7677             if (j.eq.l+1) then
7678               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7679      &          b1(1,itj1),auxvec(1))
7680               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
7681             else
7682               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
7683      &          b1(1,itl1),auxvec(1))
7684               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
7685             endif
7686             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7687      &        pizda(1,1))
7688             vv(1)=pizda(1,1)-pizda(2,2)
7689             vv(2)=pizda(2,1)+pizda(1,2)
7690             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7691             if (swap) then
7692               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7693 #ifdef MOMENT
7694                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7695      &             -(s1+s2+s4)
7696 #else
7697                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
7698      &             -(s2+s4)
7699 #endif
7700                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
7701               else
7702 #ifdef MOMENT
7703                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
7704 #else
7705                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
7706 #endif
7707                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7708               endif
7709             else
7710 #ifdef MOMENT
7711               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7712 #else
7713               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7714 #endif
7715               if (l.eq.j+1) then
7716                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7717               else
7718                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7719               endif
7720             endif
7721           enddo
7722         enddo
7723       enddo
7724       return
7725       end
7726 c----------------------------------------------------------------------------
7727       double precision function eello_turn6(i,jj,kk)
7728       implicit real*8 (a-h,o-z)
7729       include 'DIMENSIONS'
7730       include 'COMMON.IOUNITS'
7731       include 'COMMON.CHAIN'
7732       include 'COMMON.DERIV'
7733       include 'COMMON.INTERACT'
7734       include 'COMMON.CONTACTS'
7735       include 'COMMON.TORSION'
7736       include 'COMMON.VAR'
7737       include 'COMMON.GEO'
7738       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
7739      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
7740      &  ggg1(3),ggg2(3)
7741       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
7742      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
7743 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
7744 C           the respective energy moment and not to the cluster cumulant.
7745       s1=0.0d0
7746       s8=0.0d0
7747       s13=0.0d0
7748 c
7749       eello_turn6=0.0d0
7750       j=i+4
7751       k=i+1
7752       l=i+3
7753       iti=itortyp(itype(i))
7754       itk=itortyp(itype(k))
7755       itk1=itortyp(itype(k+1))
7756       itl=itortyp(itype(l))
7757       itj=itortyp(itype(j))
7758 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
7759 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
7760 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7761 cd        eello6=0.0d0
7762 cd        return
7763 cd      endif
7764 cd      write (iout,*)
7765 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7766 cd     &   ' and',k,l
7767 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
7768       do iii=1,2
7769         do kkk=1,5
7770           do lll=1,3
7771             derx_turn(lll,kkk,iii)=0.0d0
7772           enddo
7773         enddo
7774       enddo
7775 cd      eij=1.0d0
7776 cd      ekl=1.0d0
7777 cd      ekont=1.0d0
7778       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7779 cd      eello6_5=0.0d0
7780 cd      write (2,*) 'eello6_5',eello6_5
7781 #ifdef MOMENT
7782       call transpose2(AEA(1,1,1),auxmat(1,1))
7783       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
7784       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
7785       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
7786 #endif
7787       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7788       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
7789       s2 = scalar2(b1(1,itk),vtemp1(1))
7790 #ifdef MOMENT
7791       call transpose2(AEA(1,1,2),atemp(1,1))
7792       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
7793       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
7794       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7795 #endif
7796       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
7797       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
7798       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
7799 #ifdef MOMENT
7800       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
7801       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
7802       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
7803       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
7804       ss13 = scalar2(b1(1,itk),vtemp4(1))
7805       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
7806 #endif
7807 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
7808 c      s1=0.0d0
7809 c      s2=0.0d0
7810 c      s8=0.0d0
7811 c      s12=0.0d0
7812 c      s13=0.0d0
7813       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
7814 C Derivatives in gamma(i+2)
7815       s1d =0.0d0
7816       s8d =0.0d0
7817 #ifdef MOMENT
7818       call transpose2(AEA(1,1,1),auxmatd(1,1))
7819       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7820       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7821       call transpose2(AEAderg(1,1,2),atempd(1,1))
7822       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7823       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7824 #endif
7825       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
7826       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7827       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7828 c      s1d=0.0d0
7829 c      s2d=0.0d0
7830 c      s8d=0.0d0
7831 c      s12d=0.0d0
7832 c      s13d=0.0d0
7833       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
7834 C Derivatives in gamma(i+3)
7835 #ifdef MOMENT
7836       call transpose2(AEA(1,1,1),auxmatd(1,1))
7837       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7838       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
7839       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
7840 #endif
7841       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
7842       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
7843       s2d = scalar2(b1(1,itk),vtemp1d(1))
7844 #ifdef MOMENT
7845       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
7846       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
7847 #endif
7848       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
7849 #ifdef MOMENT
7850       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
7851       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7852       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7853 #endif
7854 c      s1d=0.0d0
7855 c      s2d=0.0d0
7856 c      s8d=0.0d0
7857 c      s12d=0.0d0
7858 c      s13d=0.0d0
7859 #ifdef MOMENT
7860       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7861      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7862 #else
7863       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
7864      &               -0.5d0*ekont*(s2d+s12d)
7865 #endif
7866 C Derivatives in gamma(i+4)
7867       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
7868       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7869       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7870 #ifdef MOMENT
7871       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
7872       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
7873       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
7874 #endif
7875 c      s1d=0.0d0
7876 c      s2d=0.0d0
7877 c      s8d=0.0d0
7878 C      s12d=0.0d0
7879 c      s13d=0.0d0
7880 #ifdef MOMENT
7881       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
7882 #else
7883       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
7884 #endif
7885 C Derivatives in gamma(i+5)
7886 #ifdef MOMENT
7887       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
7888       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7889       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7890 #endif
7891       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
7892       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
7893       s2d = scalar2(b1(1,itk),vtemp1d(1))
7894 #ifdef MOMENT
7895       call transpose2(AEA(1,1,2),atempd(1,1))
7896       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
7897       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
7898 #endif
7899       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
7900       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7901 #ifdef MOMENT
7902       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
7903       ss13d = scalar2(b1(1,itk),vtemp4d(1))
7904       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7905 #endif
7906 c      s1d=0.0d0
7907 c      s2d=0.0d0
7908 c      s8d=0.0d0
7909 c      s12d=0.0d0
7910 c      s13d=0.0d0
7911 #ifdef MOMENT
7912       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7913      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
7914 #else
7915       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
7916      &               -0.5d0*ekont*(s2d+s12d)
7917 #endif
7918 C Cartesian derivatives
7919       do iii=1,2
7920         do kkk=1,5
7921           do lll=1,3
7922 #ifdef MOMENT
7923             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
7924             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
7925             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
7926 #endif
7927             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
7928             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
7929      &          vtemp1d(1))
7930             s2d = scalar2(b1(1,itk),vtemp1d(1))
7931 #ifdef MOMENT
7932             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
7933             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
7934             s8d = -(atempd(1,1)+atempd(2,2))*
7935      &           scalar2(cc(1,1,itl),vtemp2(1))
7936 #endif
7937             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
7938      &           auxmatd(1,1))
7939             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
7940             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
7941 c      s1d=0.0d0
7942 c      s2d=0.0d0
7943 c      s8d=0.0d0
7944 c      s12d=0.0d0
7945 c      s13d=0.0d0
7946 #ifdef MOMENT
7947             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7948      &        - 0.5d0*(s1d+s2d)
7949 #else
7950             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
7951      &        - 0.5d0*s2d
7952 #endif
7953 #ifdef MOMENT
7954             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7955      &        - 0.5d0*(s8d+s12d)
7956 #else
7957             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
7958      &        - 0.5d0*s12d
7959 #endif
7960           enddo
7961         enddo
7962       enddo
7963 #ifdef MOMENT
7964       do kkk=1,5
7965         do lll=1,3
7966           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
7967      &      achuj_tempd(1,1))
7968           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
7969           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
7970           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
7971           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
7972           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
7973      &      vtemp4d(1))
7974           ss13d = scalar2(b1(1,itk),vtemp4d(1))
7975           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
7976           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
7977         enddo
7978       enddo
7979 #endif
7980 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
7981 cd     &  16*eel_turn6_num
7982 cd      goto 1112
7983       if (j.lt.nres-1) then
7984         j1=j+1
7985         j2=j-1
7986       else
7987         j1=j-1
7988         j2=j-2
7989       endif
7990       if (l.lt.nres-1) then
7991         l1=l+1
7992         l2=l-1
7993       else
7994         l1=l-1
7995         l2=l-2
7996       endif
7997       do ll=1,3
7998         ggg1(ll)=eel_turn6*g_contij(ll,1)
7999         ggg2(ll)=eel_turn6*g_contij(ll,2)
8000         ghalf=0.5d0*ggg1(ll)
8001 cd        ghalf=0.0d0
8002         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8003      &    +ekont*derx_turn(ll,2,1)
8004         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8005         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8006      &    +ekont*derx_turn(ll,4,1)
8007         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8008         ghalf=0.5d0*ggg2(ll)
8009 cd        ghalf=0.0d0
8010         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8011      &    +ekont*derx_turn(ll,2,2)
8012         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8013         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8014      &    +ekont*derx_turn(ll,4,2)
8015         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8016       enddo
8017 cd      goto 1112
8018       do m=i+1,j-1
8019         do ll=1,3
8020           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8021         enddo
8022       enddo
8023       do m=k+1,l-1
8024         do ll=1,3
8025           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8026         enddo
8027       enddo
8028 1112  continue
8029       do m=i+2,j2
8030         do ll=1,3
8031           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8032         enddo
8033       enddo
8034       do m=k+2,l2
8035         do ll=1,3
8036           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8037         enddo
8038       enddo
8039 cd      do iii=1,nres-3
8040 cd        write (2,*) iii,g_corr6_loc(iii)
8041 cd      enddo
8042       eello_turn6=ekont*eel_turn6
8043 cd      write (2,*) 'ekont',ekont
8044 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8045       return
8046       end
8047
8048 C-----------------------------------------------------------------------------
8049       double precision function scalar(u,v)
8050 !DIR$ INLINEALWAYS scalar
8051 #ifndef OSF
8052 cDEC$ ATTRIBUTES FORCEINLINE::scalar
8053 #endif
8054       implicit none
8055       double precision u(3),v(3)
8056 cd      double precision sc
8057 cd      integer i
8058 cd      sc=0.0d0
8059 cd      do i=1,3
8060 cd        sc=sc+u(i)*v(i)
8061 cd      enddo
8062 cd      scalar=sc
8063
8064       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
8065       return
8066       end
8067 crc-------------------------------------------------
8068       SUBROUTINE MATVEC2(A1,V1,V2)
8069 !DIR$ INLINEALWAYS MATVEC2
8070 #ifndef OSF
8071 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
8072 #endif
8073       implicit real*8 (a-h,o-z)
8074       include 'DIMENSIONS'
8075       DIMENSION A1(2,2),V1(2),V2(2)
8076 c      DO 1 I=1,2
8077 c        VI=0.0
8078 c        DO 3 K=1,2
8079 c    3     VI=VI+A1(I,K)*V1(K)
8080 c        Vaux(I)=VI
8081 c    1 CONTINUE
8082
8083       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8084       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8085
8086       v2(1)=vaux1
8087       v2(2)=vaux2
8088       END
8089 C---------------------------------------
8090       SUBROUTINE MATMAT2(A1,A2,A3)
8091 #ifndef OSF
8092 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
8093 #endif
8094       implicit real*8 (a-h,o-z)
8095       include 'DIMENSIONS'
8096       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8097 c      DIMENSION AI3(2,2)
8098 c        DO  J=1,2
8099 c          A3IJ=0.0
8100 c          DO K=1,2
8101 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8102 c          enddo
8103 c          A3(I,J)=A3IJ
8104 c       enddo
8105 c      enddo
8106
8107       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8108       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8109       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8110       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8111
8112       A3(1,1)=AI3_11
8113       A3(2,1)=AI3_21
8114       A3(1,2)=AI3_12
8115       A3(2,2)=AI3_22
8116       END
8117
8118 c-------------------------------------------------------------------------
8119       double precision function scalar2(u,v)
8120 !DIR$ INLINEALWAYS scalar2
8121       implicit none
8122       double precision u(2),v(2)
8123       double precision sc
8124       integer i
8125       scalar2=u(1)*v(1)+u(2)*v(2)
8126       return
8127       end
8128
8129 C-----------------------------------------------------------------------------
8130
8131       subroutine transpose2(a,at)
8132 !DIR$ INLINEALWAYS transpose2
8133 #ifndef OSF
8134 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
8135 #endif
8136       implicit none
8137       double precision a(2,2),at(2,2)
8138       at(1,1)=a(1,1)
8139       at(1,2)=a(2,1)
8140       at(2,1)=a(1,2)
8141       at(2,2)=a(2,2)
8142       return
8143       end
8144 c--------------------------------------------------------------------------
8145       subroutine transpose(n,a,at)
8146       implicit none
8147       integer n,i,j
8148       double precision a(n,n),at(n,n)
8149       do i=1,n
8150         do j=1,n
8151           at(j,i)=a(i,j)
8152         enddo
8153       enddo
8154       return
8155       end
8156 C---------------------------------------------------------------------------
8157       subroutine prodmat3(a1,a2,kk,transp,prod)
8158 !DIR$ INLINEALWAYS prodmat3
8159 #ifndef OSF
8160 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
8161 #endif
8162       implicit none
8163       integer i,j
8164       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8165       logical transp
8166 crc      double precision auxmat(2,2),prod_(2,2)
8167
8168       if (transp) then
8169 crc        call transpose2(kk(1,1),auxmat(1,1))
8170 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8171 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8172
8173            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8174      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8175            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8176      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8177            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8178      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8179            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8180      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8181
8182       else
8183 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8184 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8185
8186            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8187      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8188            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8189      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8190            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8191      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8192            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8193      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8194
8195       endif
8196 c      call transpose2(a2(1,1),a2t(1,1))
8197
8198 crc      print *,transp
8199 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8200 crc      print *,((prod(i,j),i=1,2),j=1,2)
8201
8202       return
8203       end
8204