source/cluster/wham/src-M/energy_p_new.F

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