source/wham/src/energy_p_new.F.org

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