source/wham/src/energy_p_new.F

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