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