source/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 'DIMENSIONS.ZSCOPT'
   5       include 'DIMENSIONS.FREE'
   6
   7 #ifndef ISNAN
   8       external proc_proc
   9 #endif
  10 #ifdef WINPGI
  11 cMS$ATTRIBUTES C ::  proc_proc
  12 #endif
  13
  14       include 'COMMON.IOUNITS'
  15       double precision energia(0:max_ene),energia1(0:max_ene+1)
  16 #ifdef MPL
  17       include 'COMMON.INFO'
  18       external d_vadd
  19       integer ready
  20 #endif
  21       include 'COMMON.FFIELD'
  22       include 'COMMON.DERIV'
  23       include 'COMMON.INTERACT'
  24       include 'COMMON.SBRIDGE'
  25       include 'COMMON.CHAIN'
  26       include 'COMMON.CONTROL'
  27       double precision fact(6)
  28 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  29 cd    print *,'nnt=',nnt,' nct=',nct
  30 C
  31 C Compute the side-chain and electrostatic interaction energy
  32 C
  33       goto (101,102,103,104,105) ipot
  34 C Lennard-Jones potential.
  35   101 call elj(evdw,evdw_t)
  36 cd    print '(a)','Exit ELJ'
  37       goto 106
  38 C Lennard-Jones-Kihara potential (shifted).
  39   102 call eljk(evdw,evdw_t)
  40       goto 106
  41 C Berne-Pechukas potential (dilated LJ, angular dependence).
  42   103 call ebp(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne potential (shifted LJ, angular dependence).
  45   104 call egb(evdw,evdw_t)
  46       goto 106
  47 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  48   105 call egbv(evdw,evdw_t)
  49 C
  50 C Calculate electrostatic (H-bonding) energy of the main chain.
  51 C
  52   106 call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  53 C
  54 C Calculate excluded-volume interaction energy between peptide groups
  55 C and side chains.
  56 C
  57       call escp(evdw2,evdw2_14)
  58 c
  59 c Calculate the bond-stretching energy
  60 c
  61       call ebond(estr)
  62 c      write (iout,*) "estr",estr
  63 C
  64 C Calculate the disulfide-bridge and other energy and the contributions
  65 C from other distance constraints.
  66 cd    print *,'Calling EHPB'
  67       call edis(ehpb)
  68 cd    print *,'EHPB exitted succesfully.'
  69 C
  70 C Calculate the virtual-bond-angle energy.
  71 C
  72       call ebend(ebe)
  73 cd    print *,'Bend energy finished.'
  74 C
  75 C Calculate the SC local energy.
  76 C
  77       call esc(escloc)
  78 cd    print *,'SCLOC energy finished.'
  79 C
  80 C Calculate the virtual-bond torsional energy.
  81 C
  82 cd    print *,'nterm=',nterm
  83       call etor(etors,edihcnstr,fact(1))
  84 C
  85 C 6/23/01 Calculate double-torsional energy
  86 C
  87       call etor_d(etors_d,fact(2))
  88 C
  89 C 21/5/07 Calculate local sicdechain correlation energy
  90 C
  91       call eback_sc_corr(esccor)
  92 C
  93 C 12/1/95 Multi-body terms
  94 C
  95       n_corr=0
  96       n_corr1=0
  97       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
  98      &    .or. wturn6.gt.0.0d0) then
  99 c         print *,"calling multibody_eello"
 100          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 101 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 102 c         print *,ecorr,ecorr5,ecorr6,eturn6
 103       else
 104          ecorr=0.0d0
 105          ecorr5=0.0d0
 106          ecorr6=0.0d0
 107          eturn6=0.0d0
 108       endif
 109       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 110          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 111       endif
 112 c      write(iout,*) "TEST_ENE1 constr_homology=",constr_homology
 113       if (constr_homology.ge.1) then
 114         call e_modeller(ehomology_constr)
 115       else
 116         ehomology_constr=0.0d0
 117       endif
 118
 119 c      write(iout,*) "TEST_ENE1 ehomology_constr=",ehomology_constr
 120 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 121 #ifdef SPLITELE
 122       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 123      & +wvdwpp*evdw1
 124      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 125      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 126      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 127      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 128      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 129      & +wbond*estr+wsccor*fact(1)*esccor
 130 #else
 131       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 132      & +welec*fact(1)*(ees+evdw1)
 133      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 134      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 135      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 136      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 137      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 138      & +wbond*estr+wsccor*fact(1)*esccor
 139 #endif
 140       energia(0)=etot
 141       energia(1)=evdw
 142 #ifdef SCP14
 143       energia(2)=evdw2-evdw2_14
 144       energia(17)=evdw2_14
 145 #else
 146       energia(2)=evdw2
 147       energia(17)=0.0d0
 148 #endif
 149 #ifdef SPLITELE
 150       energia(3)=ees
 151       energia(16)=evdw1
 152 #else
 153       energia(3)=ees+evdw1
 154       energia(16)=0.0d0
 155 #endif
 156       energia(4)=ecorr
 157       energia(5)=ecorr5
 158       energia(6)=ecorr6
 159       energia(7)=eel_loc
 160       energia(8)=eello_turn3
 161       energia(9)=eello_turn4
 162       energia(10)=eturn6
 163       energia(11)=ebe
 164       energia(12)=escloc
 165       energia(13)=etors
 166       energia(14)=etors_d
 167       energia(15)=ehpb
 168       energia(18)=estr
 169       energia(19)=esccor
 170       energia(20)=edihcnstr
 171       energia(21)=evdw_t
 172       energia(22)=ehomology_constr
 173 c detecting NaNQ
 174 #ifdef ISNAN
 175 #ifdef AIX
 176       if (isnan(etot).ne.0) energia(0)=1.0d+99
 177 #else
 178       if (isnan(etot)) energia(0)=1.0d+99
 179 #endif
 180 #else
 181       i=0
 182 #ifdef WINPGI
 183       idumm=proc_proc(etot,i)
 184 #else
 185       call proc_proc(etot,i)
 186 #endif
 187       if(i.eq.1)energia(0)=1.0d+99
 188 #endif
 189 #ifdef MPL
 190 c     endif
 191 #endif
 192 #ifdef DEBUG
 193       call enerprint(energia,fact)
 194 #endif
 195       if (calc_grad) then
 196 C
 197 C Sum up the components of the Cartesian gradient.
 198 C
 199 #ifdef SPLITELE
 200       do i=1,nct
 201         do j=1,3
 202           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 203      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 204      &                wbond*gradb(j,i)+
 205      &                wstrain*ghpbc(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      &               +wliptran*gliptranc(j,i)
 215           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 216      &                  wbond*gradbx(j,i)+
 217      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 218      &                  wsccor*fact(2)*gsccorx(j,i)
 219         enddo
 220 #else
 221       do i=1,nct
 222         do j=1,3
 223           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 224      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 225      &                wbond*gradb(j,i)+
 226      &                wcorr*fact(3)*gradcorr(j,i)+
 227      &                wel_loc*fact(2)*gel_loc(j,i)+
 228      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 229      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 230      &                wcorr5*fact(4)*gradcorr5(j,i)+
 231      &                wcorr6*fact(5)*gradcorr6(j,i)+
 232      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 233      &                wsccor*fact(2)*gsccorc(j,i)
 234      &               +wliptran*gliptranc(j,i)
 235           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 236      &                  wbond*gradbx(j,i)+
 237      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 238      &                  wsccor*fact(1)*gsccorx(j,i)
 239      &                 +wliptran*gliptranx(j,i)
 240         enddo
 241 #endif
 242       enddo
 243
 244
 245       do i=1,nres-3
 246         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 247      &   +wcorr5*fact(4)*g_corr5_loc(i)
 248      &   +wcorr6*fact(5)*g_corr6_loc(i)
 249      &   +wturn4*fact(3)*gel_loc_turn4(i)
 250      &   +wturn3*fact(2)*gel_loc_turn3(i)
 251      &   +wturn6*fact(5)*gel_loc_turn6(i)
 252      &   +wel_loc*fact(2)*gel_loc_loc(i)
 253 c     &   +wsccor*fact(1)*gsccor_loc(i)
 254 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 255       enddo
 256       endif
 257       if (dyn_ss) call dyn_set_nss
 258       return
 259       end
 260 C------------------------------------------------------------------------
 261       subroutine enerprint(energia,fact)
 262       implicit real*8 (a-h,o-z)
 263       include 'DIMENSIONS'
 264       include 'DIMENSIONS.ZSCOPT'
 265       include 'COMMON.IOUNITS'
 266       include 'COMMON.FFIELD'
 267       include 'COMMON.SBRIDGE'
 268       double precision energia(0:max_ene),fact(6)
 269       etot=energia(0)
 270       evdw=energia(1)+fact(6)*energia(21)
 271 #ifdef SCP14
 272       evdw2=energia(2)+energia(17)
 273 #else
 274       evdw2=energia(2)
 275 #endif
 276       ees=energia(3)
 277 #ifdef SPLITELE
 278       evdw1=energia(16)
 279 #endif
 280       ecorr=energia(4)
 281       ecorr5=energia(5)
 282       ecorr6=energia(6)
 283       eel_loc=energia(7)
 284       eello_turn3=energia(8)
 285       eello_turn4=energia(9)
 286       eello_turn6=energia(10)
 287       ebe=energia(11)
 288       escloc=energia(12)
 289       etors=energia(13)
 290       etors_d=energia(14)
 291       ehpb=energia(15)
 292       esccor=energia(19)
 293       edihcnstr=energia(20)
 294       estr=energia(18)
 295       ehomology_constr=energia(22)
 296 #ifdef SPLITELE
 297       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 298      &  wvdwpp,
 299      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 300      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 301      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 302      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 303      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 304      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,etot
 305    10 format (/'Virtual-chain energies:'//
 306      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 307      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 308      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 309      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 310      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 311      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 312      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 313      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 314      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 315      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 316      & ' (SS bridges & dist. cnstr.)'/
 317      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 318      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 319      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 320      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 321      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 322      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 323      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 324      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 325      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 326      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 327      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 328      & 'ETOT=  ',1pE16.6,' (total)')
 329 #else
 330       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 331      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 332      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 333      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 334      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 335      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 336      &  edihcnstr,ehomology_constr,ebr*nss,
 337      &  etot
 338    10 format (/'Virtual-chain energies:'//
 339      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 340      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 341      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 342      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 343      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 344      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 345      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 346      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 347      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 348      & ' (SS bridges & dist. cnstr.)'/
 349      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 350      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 351      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 352      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 353      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 354      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 355      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 356      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 357      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 358      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 359      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 360      & 'ETOT=  ',1pE16.6,' (total)')
 361 #endif
 362       return
 363       end
 364 C-----------------------------------------------------------------------
 365       subroutine elj(evdw,evdw_t)
 366 C
 367 C This subroutine calculates the interaction energy of nonbonded side chains
 368 C assuming the LJ potential of interaction.
 369 C
 370       implicit real*8 (a-h,o-z)
 371       include 'DIMENSIONS'
 372       include 'DIMENSIONS.ZSCOPT'
 373       include "DIMENSIONS.COMPAR"
 374       parameter (accur=1.0d-10)
 375       include 'COMMON.GEO'
 376       include 'COMMON.VAR'
 377       include 'COMMON.LOCAL'
 378       include 'COMMON.CHAIN'
 379       include 'COMMON.DERIV'
 380       include 'COMMON.INTERACT'
 381       include 'COMMON.TORSION'
 382       include 'COMMON.ENEPS'
 383       include 'COMMON.SBRIDGE'
 384       include 'COMMON.NAMES'
 385       include 'COMMON.IOUNITS'
 386       include 'COMMON.CONTACTS'
 387       dimension gg(3)
 388       integer icant
 389       external icant
 390 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 391       do i=1,210
 392         do j=1,2
 393           eneps_temp(j,i)=0.0d0
 394         enddo
 395       enddo
 396       evdw=0.0D0
 397       evdw_t=0.0d0
 398       do i=iatsc_s,iatsc_e
 399         itypi=iabs(itype(i))
 400         if (itypi.eq.ntyp1) cycle
 401         itypi1=iabs(itype(i+1))
 402         xi=c(1,nres+i)
 403         yi=c(2,nres+i)
 404         zi=c(3,nres+i)
 405 C Change 12/1/95
 406         num_conti=0
 407 C
 408 C Calculate SC interaction energy.
 409 C
 410         do iint=1,nint_gr(i)
 411 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 412 cd   &                  'iend=',iend(i,iint)
 413           do j=istart(i,iint),iend(i,iint)
 414             itypj=iabs(itype(j))
 415             if (itypj.eq.ntyp1) cycle
 416             xj=c(1,nres+j)-xi
 417             yj=c(2,nres+j)-yi
 418             zj=c(3,nres+j)-zi
 419 C Change 12/1/95 to calculate four-body interactions
 420             rij=xj*xj+yj*yj+zj*zj
 421             rrij=1.0D0/rij
 422 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 423             eps0ij=eps(itypi,itypj)
 424             fac=rrij**expon2
 425             e1=fac*fac*aa
 426             e2=fac*bb
 427             evdwij=e1+e2
 428             ij=icant(itypi,itypj)
 429             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 430             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 431 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 432 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 433 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 434 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 435 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 436 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 437             if (bb.gt.0.0d0) then
 438               evdw=evdw+evdwij
 439             else
 440               evdw_t=evdw_t+evdwij
 441             endif
 442             if (calc_grad) then
 443 C
 444 C Calculate the components of the gradient in DC and X
 445 C
 446             fac=-rrij*(e1+evdwij)
 447             gg(1)=xj*fac
 448             gg(2)=yj*fac
 449             gg(3)=zj*fac
 450             do k=1,3
 451               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 452               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 453             enddo
 454             do k=i,j-1
 455               do l=1,3
 456                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 457               enddo
 458             enddo
 459             endif
 460 C
 461 C 12/1/95, revised on 5/20/97
 462 C
 463 C Calculate the contact function. The ith column of the array JCONT will
 464 C contain the numbers of atoms that make contacts with the atom I (of numbers
 465 C greater than I). The arrays FACONT and GACONT will contain the values of
 466 C the contact function and its derivative.
 467 C
 468 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 469 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 470 C Uncomment next line, if the correlation interactions are contact function only
 471             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 472               rij=dsqrt(rij)
 473               sigij=sigma(itypi,itypj)
 474               r0ij=rs0(itypi,itypj)
 475 C
 476 C Check whether the SC's are not too far to make a contact.
 477 C
 478               rcut=1.5d0*r0ij
 479               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 480 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 481 C
 482               if (fcont.gt.0.0D0) then
 483 C If the SC-SC distance if close to sigma, apply spline.
 484 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 485 cAdam &             fcont1,fprimcont1)
 486 cAdam           fcont1=1.0d0-fcont1
 487 cAdam           if (fcont1.gt.0.0d0) then
 488 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 489 cAdam             fcont=fcont*fcont1
 490 cAdam           endif
 491 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 492 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 493 cga             do k=1,3
 494 cga               gg(k)=gg(k)*eps0ij
 495 cga             enddo
 496 cga             eps0ij=-evdwij*eps0ij
 497 C Uncomment for AL's type of SC correlation interactions.
 498 cadam           eps0ij=-evdwij
 499                 num_conti=num_conti+1
 500                 jcont(num_conti,i)=j
 501                 facont(num_conti,i)=fcont*eps0ij
 502                 fprimcont=eps0ij*fprimcont/rij
 503                 fcont=expon*fcont
 504 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 505 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 506 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 507 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 508                 gacont(1,num_conti,i)=-fprimcont*xj
 509                 gacont(2,num_conti,i)=-fprimcont*yj
 510                 gacont(3,num_conti,i)=-fprimcont*zj
 511 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 512 cd              write (iout,'(2i3,3f10.5)')
 513 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 514               endif
 515             endif
 516           enddo      ! j
 517         enddo        ! iint
 518 C Change 12/1/95
 519         num_cont(i)=num_conti
 520       enddo          ! i
 521       if (calc_grad) then
 522       do i=1,nct
 523         do j=1,3
 524           gvdwc(j,i)=expon*gvdwc(j,i)
 525           gvdwx(j,i)=expon*gvdwx(j,i)
 526         enddo
 527       enddo
 528       endif
 529 C******************************************************************************
 530 C
 531 C                              N O T E !!!
 532 C
 533 C To save time, the factor of EXPON has been extracted from ALL components
 534 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 535 C use!
 536 C
 537 C******************************************************************************
 538       return
 539       end
 540 C-----------------------------------------------------------------------------
 541       subroutine eljk(evdw,evdw_t)
 542 C
 543 C This subroutine calculates the interaction energy of nonbonded side chains
 544 C assuming the LJK potential of interaction.
 545 C
 546       implicit real*8 (a-h,o-z)
 547       include 'DIMENSIONS'
 548       include 'DIMENSIONS.ZSCOPT'
 549       include "DIMENSIONS.COMPAR"
 550       include 'COMMON.GEO'
 551       include 'COMMON.VAR'
 552       include 'COMMON.LOCAL'
 553       include 'COMMON.CHAIN'
 554       include 'COMMON.DERIV'
 555       include 'COMMON.INTERACT'
 556       include 'COMMON.ENEPS'
 557       include 'COMMON.IOUNITS'
 558       include 'COMMON.NAMES'
 559       dimension gg(3)
 560       logical scheck
 561       integer icant
 562       external icant
 563 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 564       do i=1,210
 565         do j=1,2
 566           eneps_temp(j,i)=0.0d0
 567         enddo
 568       enddo
 569       evdw=0.0D0
 570       evdw_t=0.0d0
 571       do i=iatsc_s,iatsc_e
 572         itypi=iabs(itype(i))
 573         if (itypi.eq.ntyp1) cycle
 574         itypi1=iabs(itype(i+1))
 575         xi=c(1,nres+i)
 576         yi=c(2,nres+i)
 577         zi=c(3,nres+i)
 578 C
 579 C Calculate SC interaction energy.
 580 C
 581         do iint=1,nint_gr(i)
 582           do j=istart(i,iint),iend(i,iint)
 583             itypj=iabs(itype(j))
 584             if (itypj.eq.ntyp1) cycle
 585             xj=c(1,nres+j)-xi
 586             yj=c(2,nres+j)-yi
 587             zj=c(3,nres+j)-zi
 588             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 589             fac_augm=rrij**expon
 590             e_augm=augm(itypi,itypj)*fac_augm
 591             r_inv_ij=dsqrt(rrij)
 592             rij=1.0D0/r_inv_ij
 593             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 594             fac=r_shift_inv**expon
 595             e1=fac*fac*aa
 596             e2=fac*bb
 597             evdwij=e_augm+e1+e2
 598             ij=icant(itypi,itypj)
 599             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 600      &        /dabs(eps(itypi,itypj))
 601             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 602 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 603 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 604 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 605 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 606 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 607 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 608 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 609             if (bb.gt.0.0d0) then
 610               evdw=evdw+evdwij
 611             else
 612               evdw_t=evdw_t+evdwij
 613             endif
 614             if (calc_grad) then
 615 C
 616 C Calculate the components of the gradient in DC and X
 617 C
 618             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 619             gg(1)=xj*fac
 620             gg(2)=yj*fac
 621             gg(3)=zj*fac
 622             do k=1,3
 623               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 624               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 625             enddo
 626             do k=i,j-1
 627               do l=1,3
 628                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 629               enddo
 630             enddo
 631             endif
 632           enddo      ! j
 633         enddo        ! iint
 634       enddo          ! i
 635       if (calc_grad) then
 636       do i=1,nct
 637         do j=1,3
 638           gvdwc(j,i)=expon*gvdwc(j,i)
 639           gvdwx(j,i)=expon*gvdwx(j,i)
 640         enddo
 641       enddo
 642       endif
 643       return
 644       end
 645 C-----------------------------------------------------------------------------
 646       subroutine ebp(evdw,evdw_t)
 647 C
 648 C This subroutine calculates the interaction energy of nonbonded side chains
 649 C assuming the Berne-Pechukas potential of interaction.
 650 C
 651       implicit real*8 (a-h,o-z)
 652       include 'DIMENSIONS'
 653       include 'DIMENSIONS.ZSCOPT'
 654       include "DIMENSIONS.COMPAR"
 655       include 'COMMON.GEO'
 656       include 'COMMON.VAR'
 657       include 'COMMON.LOCAL'
 658       include 'COMMON.CHAIN'
 659       include 'COMMON.DERIV'
 660       include 'COMMON.NAMES'
 661       include 'COMMON.INTERACT'
 662       include 'COMMON.ENEPS'
 663       include 'COMMON.IOUNITS'
 664       include 'COMMON.CALC'
 665       common /srutu/ icall
 666 c     double precision rrsave(maxdim)
 667       logical lprn
 668       integer icant
 669       external icant
 670       do i=1,210
 671         do j=1,2
 672           eneps_temp(j,i)=0.0d0
 673         enddo
 674       enddo
 675       evdw=0.0D0
 676       evdw_t=0.0d0
 677 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 678 c     if (icall.eq.0) then
 679 c       lprn=.true.
 680 c     else
 681         lprn=.false.
 682 c     endif
 683       ind=0
 684       do i=iatsc_s,iatsc_e
 685         itypi=iabs(itype(i))
 686         if (itypi.eq.ntyp1) cycle
 687         itypi1=iabs(itype(i+1))
 688         xi=c(1,nres+i)
 689         yi=c(2,nres+i)
 690         zi=c(3,nres+i)
 691         dxi=dc_norm(1,nres+i)
 692         dyi=dc_norm(2,nres+i)
 693         dzi=dc_norm(3,nres+i)
 694         dsci_inv=vbld_inv(i+nres)
 695 C
 696 C Calculate SC interaction energy.
 697 C
 698         do iint=1,nint_gr(i)
 699           do j=istart(i,iint),iend(i,iint)
 700             ind=ind+1
 701             itypj=iabs(itype(j))
 702             if (itypj.eq.ntyp1) cycle
 703             dscj_inv=vbld_inv(j+nres)
 704             chi1=chi(itypi,itypj)
 705             chi2=chi(itypj,itypi)
 706             chi12=chi1*chi2
 707             chip1=chip(itypi)
 708             chip2=chip(itypj)
 709             chip12=chip1*chip2
 710             alf1=alp(itypi)
 711             alf2=alp(itypj)
 712             alf12=0.5D0*(alf1+alf2)
 713 C For diagnostics only!!!
 714 c           chi1=0.0D0
 715 c           chi2=0.0D0
 716 c           chi12=0.0D0
 717 c           chip1=0.0D0
 718 c           chip2=0.0D0
 719 c           chip12=0.0D0
 720 c           alf1=0.0D0
 721 c           alf2=0.0D0
 722 c           alf12=0.0D0
 723             xj=c(1,nres+j)-xi
 724             yj=c(2,nres+j)-yi
 725             zj=c(3,nres+j)-zi
 726             dxj=dc_norm(1,nres+j)
 727             dyj=dc_norm(2,nres+j)
 728             dzj=dc_norm(3,nres+j)
 729             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 730 cd          if (icall.eq.0) then
 731 cd            rrsave(ind)=rrij
 732 cd          else
 733 cd            rrij=rrsave(ind)
 734 cd          endif
 735             rij=dsqrt(rrij)
 736 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 737             call sc_angular
 738 C Calculate whole angle-dependent part of epsilon and contributions
 739 C to its derivatives
 740             fac=(rrij*sigsq)**expon2
 741             e1=fac*fac*aa
 742             e2=fac*bb
 743             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 744             eps2der=evdwij*eps3rt
 745             eps3der=evdwij*eps2rt
 746             evdwij=evdwij*eps2rt*eps3rt
 747             ij=icant(itypi,itypj)
 748             aux=eps1*eps2rt**2*eps3rt**2
 749             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 750      &        /dabs(eps(itypi,itypj))
 751             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 752             if (bb.gt.0.0d0) then
 753               evdw=evdw+evdwij
 754             else
 755               evdw_t=evdw_t+evdwij
 756             endif
 757             if (calc_grad) then
 758             if (lprn) then
 759             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 760             epsi=bb**2/aa
 761             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 762      &        restyp(itypi),i,restyp(itypj),j,
 763      &        epsi,sigm,chi1,chi2,chip1,chip2,
 764      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 765      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 766      &        evdwij
 767             endif
 768 C Calculate gradient components.
 769             e1=e1*eps1*eps2rt**2*eps3rt**2
 770             fac=-expon*(e1+evdwij)
 771             sigder=fac/sigsq
 772             fac=rrij*fac
 773 C Calculate radial part of the gradient
 774             gg(1)=xj*fac
 775             gg(2)=yj*fac
 776             gg(3)=zj*fac
 777 C Calculate the angular part of the gradient and sum add the contributions
 778 C to the appropriate components of the Cartesian gradient.
 779             call sc_grad
 780             endif
 781           enddo      ! j
 782         enddo        ! iint
 783       enddo          ! i
 784 c     stop
 785       return
 786       end
 787 C-----------------------------------------------------------------------------
 788       subroutine egb(evdw,evdw_t)
 789 C
 790 C This subroutine calculates the interaction energy of nonbonded side chains
 791 C assuming the Gay-Berne potential of interaction.
 792 C
 793       implicit real*8 (a-h,o-z)
 794       include 'DIMENSIONS'
 795       include 'DIMENSIONS.ZSCOPT'
 796       include "DIMENSIONS.COMPAR"
 797       include 'COMMON.GEO'
 798       include 'COMMON.VAR'
 799       include 'COMMON.LOCAL'
 800       include 'COMMON.CHAIN'
 801       include 'COMMON.DERIV'
 802       include 'COMMON.NAMES'
 803       include 'COMMON.INTERACT'
 804       include 'COMMON.ENEPS'
 805       include 'COMMON.IOUNITS'
 806       include 'COMMON.CALC'
 807       include 'COMMON.SBRIDGE'
 808       logical lprn
 809       common /srutu/icall
 810       integer icant,xshift,yshift,zshift
 811       external icant
 812       do i=1,210
 813         do j=1,2
 814           eneps_temp(j,i)=0.0d0
 815         enddo
 816       enddo
 817 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 818       evdw=0.0D0
 819       evdw_t=0.0d0
 820       lprn=.false.
 821 c      if (icall.gt.0) lprn=.true.
 822       ind=0
 823       do i=iatsc_s,iatsc_e
 824         itypi=iabs(itype(i))
 825         if (itypi.eq.ntyp1) cycle
 826         itypi1=iabs(itype(i+1))
 827         xi=c(1,nres+i)
 828         yi=c(2,nres+i)
 829         zi=c(3,nres+i)
 830 C returning the ith atom to box
 831           xi=mod(xi,boxxsize)
 832           if (xi.lt.0) xi=xi+boxxsize
 833           yi=mod(yi,boxysize)
 834           if (yi.lt.0) yi=yi+boxysize
 835           zi=mod(zi,boxzsize)
 836           if (zi.lt.0) zi=zi+boxzsize
 837        if ((zi.gt.bordlipbot)
 838      &.and.(zi.lt.bordliptop)) then
 839 C the energy transfer exist
 840         if (zi.lt.buflipbot) then
 841 C what fraction I am in
 842          fracinbuf=1.0d0-
 843      &        ((zi-bordlipbot)/lipbufthick)
 844 C lipbufthick is thickenes of lipid buffore
 845          sslipi=sscalelip(fracinbuf)
 846          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 847         elseif (zi.gt.bufliptop) then
 848          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 849          sslipi=sscalelip(fracinbuf)
 850          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 851         else
 852          sslipi=1.0d0
 853          ssgradlipi=0.0
 854         endif
 855        else
 856          sslipi=0.0d0
 857          ssgradlipi=0.0
 858        endif
 859
 860         dxi=dc_norm(1,nres+i)
 861         dyi=dc_norm(2,nres+i)
 862         dzi=dc_norm(3,nres+i)
 863         dsci_inv=vbld_inv(i+nres)
 864 C
 865 C Calculate SC interaction energy.
 866 C
 867         do iint=1,nint_gr(i)
 868           do j=istart(i,iint),iend(i,iint)
 869             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 870               call dyn_ssbond_ene(i,j,evdwij)
 871               evdw=evdw+evdwij
 872 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 873 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
 874 C triple bond artifac removal
 875              do k=j+1,iend(i,iint)
 876 C search over all next residues
 877               if (dyn_ss_mask(k)) then
 878 C check if they are cysteins
 879 C              write(iout,*) 'k=',k
 880               call triple_ssbond_ene(i,j,k,evdwij)
 881 C call the energy function that removes the artifical triple disulfide
 882 C bond the soubroutine is located in ssMD.F
 883               evdw=evdw+evdwij
 884 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
 885 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
 886               endif!dyn_ss_mask(k)
 887              enddo! k
 888             ELSE
 889             ind=ind+1
 890             itypj=iabs(itype(j))
 891             if (itypj.eq.ntyp1) cycle
 892             dscj_inv=vbld_inv(j+nres)
 893             sig0ij=sigma(itypi,itypj)
 894             chi1=chi(itypi,itypj)
 895             chi2=chi(itypj,itypi)
 896             chi12=chi1*chi2
 897             chip1=chip(itypi)
 898             chip2=chip(itypj)
 899             chip12=chip1*chip2
 900             alf1=alp(itypi)
 901             alf2=alp(itypj)
 902             alf12=0.5D0*(alf1+alf2)
 903 C For diagnostics only!!!
 904 c           chi1=0.0D0
 905 c           chi2=0.0D0
 906 c           chi12=0.0D0
 907 c           chip1=0.0D0
 908 c           chip2=0.0D0
 909 c           chip12=0.0D0
 910 c           alf1=0.0D0
 911 c           alf2=0.0D0
 912 c           alf12=0.0D0
 913             xj=c(1,nres+j)
 914             yj=c(2,nres+j)
 915             zj=c(3,nres+j)
 916 C returning jth atom to box
 917           xj=mod(xj,boxxsize)
 918           if (xj.lt.0) xj=xj+boxxsize
 919           yj=mod(yj,boxysize)
 920           if (yj.lt.0) yj=yj+boxysize
 921           zj=mod(zj,boxzsize)
 922           if (zj.lt.0) zj=zj+boxzsize
 923        if ((zj.gt.bordlipbot)
 924      &.and.(zj.lt.bordliptop)) then
 925 C the energy transfer exist
 926         if (zj.lt.buflipbot) then
 927 C what fraction I am in
 928          fracinbuf=1.0d0-
 929      &        ((zj-bordlipbot)/lipbufthick)
 930 C lipbufthick is thickenes of lipid buffore
 931          sslipj=sscalelip(fracinbuf)
 932          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
 933         elseif (zj.gt.bufliptop) then
 934          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
 935          sslipj=sscalelip(fracinbuf)
 936          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
 937         else
 938          sslipj=1.0d0
 939          ssgradlipj=0.0
 940         endif
 941        else
 942          sslipj=0.0d0
 943          ssgradlipj=0.0
 944        endif
 945       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 946      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 947       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
 948      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
 949 C       if (aa.ne.aa_aq(itypi,itypj)) then
 950
 951 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
 952 C     & bb_aq(itypi,itypj)-bb,
 953 C     & sslipi,sslipj
 954 C         endif
 955
 956 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
 957 C checking the distance
 958       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 959       xj_safe=xj
 960       yj_safe=yj
 961       zj_safe=zj
 962       subchap=0
 963 C finding the closest
 964       do xshift=-1,1
 965       do yshift=-1,1
 966       do zshift=-1,1
 967           xj=xj_safe+xshift*boxxsize
 968           yj=yj_safe+yshift*boxysize
 969           zj=zj_safe+zshift*boxzsize
 970           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
 971           if(dist_temp.lt.dist_init) then
 972             dist_init=dist_temp
 973             xj_temp=xj
 974             yj_temp=yj
 975             zj_temp=zj
 976             subchap=1
 977           endif
 978        enddo
 979        enddo
 980        enddo
 981        if (subchap.eq.1) then
 982           xj=xj_temp-xi
 983           yj=yj_temp-yi
 984           zj=zj_temp-zi
 985        else
 986           xj=xj_safe-xi
 987           yj=yj_safe-yi
 988           zj=zj_safe-zi
 989        endif
 990
 991             dxj=dc_norm(1,nres+j)
 992             dyj=dc_norm(2,nres+j)
 993             dzj=dc_norm(3,nres+j)
 994 c            write (iout,*) i,j,xj,yj,zj
 995             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 996             rij=dsqrt(rrij)
 997             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
 998             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
 999             if (sss.le.0.0) cycle
1000 C Calculate angle-dependent terms of energy and contributions to their
1001 C derivatives.
1002
1003             call sc_angular
1004             sigsq=1.0D0/sigsq
1005             sig=sig0ij*dsqrt(sigsq)
1006             rij_shift=1.0D0/rij-sig+sig0ij
1007 C I hate to put IF's in the loops, but here don't have another choice!!!!
1008             if (rij_shift.le.0.0D0) then
1009               evdw=1.0D20
1010               return
1011             endif
1012             sigder=-sig*sigsq
1013 c---------------------------------------------------------------
1014             rij_shift=1.0D0/rij_shift
1015             fac=rij_shift**expon
1016             e1=fac*fac*aa
1017             e2=fac*bb
1018             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1019             eps2der=evdwij*eps3rt
1020             eps3der=evdwij*eps2rt
1021             evdwij=evdwij*eps2rt*eps3rt
1022             if (bb.gt.0) then
1023               evdw=evdw+evdwij*sss
1024             else
1025               evdw_t=evdw_t+evdwij*sss
1026             endif
1027             ij=icant(itypi,itypj)
1028             aux=eps1*eps2rt**2*eps3rt**2
1029             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1030      &        /dabs(eps(itypi,itypj))
1031             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1032 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1033 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1034 c     &         aux*e2/eps(itypi,itypj)
1035 c            if (lprn) then
1036             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1037             epsi=bb**2/aa
1038 C#define DEBUG
1039 #ifdef DEBUG
1040             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1041      &        restyp(itypi),i,restyp(itypj),j,
1042      &        epsi,sigm,chi1,chi2,chip1,chip2,
1043      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1044      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1045      &        evdwij
1046              write (iout,*) "partial sum", evdw, evdw_t
1047 #endif
1048 C#undef DEBUG
1049 c            endif
1050             if (calc_grad) then
1051 C Calculate gradient components.
1052             e1=e1*eps1*eps2rt**2*eps3rt**2
1053             fac=-expon*(e1+evdwij)*rij_shift
1054             sigder=fac*sigder
1055             fac=rij*fac
1056             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1057 C Calculate the radial part of the gradient
1058             gg(1)=xj*fac
1059             gg(2)=yj*fac
1060             gg(3)=zj*fac
1061 C Calculate angular part of the gradient.
1062             call sc_grad
1063             endif
1064 C            write(iout,*)  "partial sum", evdw, evdw_t
1065             ENDIF    ! dyn_ss
1066           enddo      ! j
1067         enddo        ! iint
1068       enddo          ! i
1069       return
1070       end
1071 C-----------------------------------------------------------------------------
1072       subroutine egbv(evdw,evdw_t)
1073 C
1074 C This subroutine calculates the interaction energy of nonbonded side chains
1075 C assuming the Gay-Berne-Vorobjev potential of interaction.
1076 C
1077       implicit real*8 (a-h,o-z)
1078       include 'DIMENSIONS'
1079       include 'DIMENSIONS.ZSCOPT'
1080       include "DIMENSIONS.COMPAR"
1081       include 'COMMON.GEO'
1082       include 'COMMON.VAR'
1083       include 'COMMON.LOCAL'
1084       include 'COMMON.CHAIN'
1085       include 'COMMON.DERIV'
1086       include 'COMMON.NAMES'
1087       include 'COMMON.INTERACT'
1088       include 'COMMON.ENEPS'
1089       include 'COMMON.IOUNITS'
1090       include 'COMMON.CALC'
1091       common /srutu/ icall
1092       logical lprn
1093       integer icant
1094       external icant
1095       do i=1,210
1096         do j=1,2
1097           eneps_temp(j,i)=0.0d0
1098         enddo
1099       enddo
1100       evdw=0.0D0
1101       evdw_t=0.0d0
1102 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1103       evdw=0.0D0
1104       lprn=.false.
1105 c      if (icall.gt.0) lprn=.true.
1106       ind=0
1107       do i=iatsc_s,iatsc_e
1108         itypi=iabs(itype(i))
1109         if (itypi.eq.ntyp1) cycle
1110         itypi1=iabs(itype(i+1))
1111         xi=c(1,nres+i)
1112         yi=c(2,nres+i)
1113         zi=c(3,nres+i)
1114         dxi=dc_norm(1,nres+i)
1115         dyi=dc_norm(2,nres+i)
1116         dzi=dc_norm(3,nres+i)
1117         dsci_inv=vbld_inv(i+nres)
1118 C
1119 C Calculate SC interaction energy.
1120 C
1121         do iint=1,nint_gr(i)
1122           do j=istart(i,iint),iend(i,iint)
1123             ind=ind+1
1124             itypj=iabs(itype(j))
1125             if (itypj.eq.ntyp1) cycle
1126             dscj_inv=vbld_inv(j+nres)
1127             sig0ij=sigma(itypi,itypj)
1128             r0ij=r0(itypi,itypj)
1129             chi1=chi(itypi,itypj)
1130             chi2=chi(itypj,itypi)
1131             chi12=chi1*chi2
1132             chip1=chip(itypi)
1133             chip2=chip(itypj)
1134             chip12=chip1*chip2
1135             alf1=alp(itypi)
1136             alf2=alp(itypj)
1137             alf12=0.5D0*(alf1+alf2)
1138 C For diagnostics only!!!
1139 c           chi1=0.0D0
1140 c           chi2=0.0D0
1141 c           chi12=0.0D0
1142 c           chip1=0.0D0
1143 c           chip2=0.0D0
1144 c           chip12=0.0D0
1145 c           alf1=0.0D0
1146 c           alf2=0.0D0
1147 c           alf12=0.0D0
1148             xj=c(1,nres+j)-xi
1149             yj=c(2,nres+j)-yi
1150             zj=c(3,nres+j)-zi
1151             dxj=dc_norm(1,nres+j)
1152             dyj=dc_norm(2,nres+j)
1153             dzj=dc_norm(3,nres+j)
1154             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1155             rij=dsqrt(rrij)
1156 C Calculate angle-dependent terms of energy and contributions to their
1157 C derivatives.
1158             call sc_angular
1159             sigsq=1.0D0/sigsq
1160             sig=sig0ij*dsqrt(sigsq)
1161             rij_shift=1.0D0/rij-sig+r0ij
1162 C I hate to put IF's in the loops, but here don't have another choice!!!!
1163             if (rij_shift.le.0.0D0) then
1164               evdw=1.0D20
1165               return
1166             endif
1167             sigder=-sig*sigsq
1168 c---------------------------------------------------------------
1169             rij_shift=1.0D0/rij_shift
1170             fac=rij_shift**expon
1171             e1=fac*fac*aa
1172             e2=fac*bb
1173             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1174             eps2der=evdwij*eps3rt
1175             eps3der=evdwij*eps2rt
1176             fac_augm=rrij**expon
1177             e_augm=augm(itypi,itypj)*fac_augm
1178             evdwij=evdwij*eps2rt*eps3rt
1179             if (bb.gt.0.0d0) then
1180               evdw=evdw+evdwij+e_augm
1181             else
1182               evdw_t=evdw_t+evdwij+e_augm
1183             endif
1184             ij=icant(itypi,itypj)
1185             aux=eps1*eps2rt**2*eps3rt**2
1186             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1187      &        /dabs(eps(itypi,itypj))
1188             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1189 c            eneps_temp(ij)=eneps_temp(ij)
1190 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1191 c            if (lprn) then
1192 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1193 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1194 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1195 c     &        restyp(itypi),i,restyp(itypj),j,
1196 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1197 c     &        chi1,chi2,chip1,chip2,
1198 c     &        eps1,eps2rt**2,eps3rt**2,
1199 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1200 c     &        evdwij+e_augm
1201 c            endif
1202             if (calc_grad) then
1203 C Calculate gradient components.
1204             e1=e1*eps1*eps2rt**2*eps3rt**2
1205             fac=-expon*(e1+evdwij)*rij_shift
1206             sigder=fac*sigder
1207             fac=rij*fac-2*expon*rrij*e_augm
1208 C Calculate the radial part of the gradient
1209             gg(1)=xj*fac
1210             gg(2)=yj*fac
1211             gg(3)=zj*fac
1212 C Calculate angular part of the gradient.
1213             call sc_grad
1214             endif
1215           enddo      ! j
1216         enddo        ! iint
1217       enddo          ! i
1218       return
1219       end
1220 C-----------------------------------------------------------------------------
1221       subroutine sc_angular
1222 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1223 C om12. Called by ebp, egb, and egbv.
1224       implicit none
1225       include 'COMMON.CALC'
1226       erij(1)=xj*rij
1227       erij(2)=yj*rij
1228       erij(3)=zj*rij
1229       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1230       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1231       om12=dxi*dxj+dyi*dyj+dzi*dzj
1232       chiom12=chi12*om12
1233 C Calculate eps1(om12) and its derivative in om12
1234       faceps1=1.0D0-om12*chiom12
1235       faceps1_inv=1.0D0/faceps1
1236       eps1=dsqrt(faceps1_inv)
1237 C Following variable is eps1*deps1/dom12
1238       eps1_om12=faceps1_inv*chiom12
1239 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1240 C and om12.
1241       om1om2=om1*om2
1242       chiom1=chi1*om1
1243       chiom2=chi2*om2
1244       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1245       sigsq=1.0D0-facsig*faceps1_inv
1246       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1247       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1248       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1249 C Calculate eps2 and its derivatives in om1, om2, and om12.
1250       chipom1=chip1*om1
1251       chipom2=chip2*om2
1252       chipom12=chip12*om12
1253       facp=1.0D0-om12*chipom12
1254       facp_inv=1.0D0/facp
1255       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1256 C Following variable is the square root of eps2
1257       eps2rt=1.0D0-facp1*facp_inv
1258 C Following three variables are the derivatives of the square root of eps
1259 C in om1, om2, and om12.
1260       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1261       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1262       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1263 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1264       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1265 C Calculate whole angle-dependent part of epsilon and contributions
1266 C to its derivatives
1267       return
1268       end
1269 C----------------------------------------------------------------------------
1270       subroutine sc_grad
1271       implicit real*8 (a-h,o-z)
1272       include 'DIMENSIONS'
1273       include 'DIMENSIONS.ZSCOPT'
1274       include 'COMMON.CHAIN'
1275       include 'COMMON.DERIV'
1276       include 'COMMON.CALC'
1277       double precision dcosom1(3),dcosom2(3)
1278       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1279       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1280       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1281      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1282       do k=1,3
1283         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1284         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1285       enddo
1286       do k=1,3
1287         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1288       enddo
1289       do k=1,3
1290         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1291      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1292      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1293         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1294      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1295      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1296       enddo
1297 C
1298 C Calculate the components of the gradient in DC and X
1299 C
1300       do k=i,j-1
1301         do l=1,3
1302           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1303         enddo
1304       enddo
1305       return
1306       end
1307 c------------------------------------------------------------------------------
1308       subroutine vec_and_deriv
1309       implicit real*8 (a-h,o-z)
1310       include 'DIMENSIONS'
1311       include 'DIMENSIONS.ZSCOPT'
1312       include 'COMMON.IOUNITS'
1313       include 'COMMON.GEO'
1314       include 'COMMON.VAR'
1315       include 'COMMON.LOCAL'
1316       include 'COMMON.CHAIN'
1317       include 'COMMON.VECTORS'
1318       include 'COMMON.DERIV'
1319       include 'COMMON.INTERACT'
1320       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1321 C Compute the local reference systems. For reference system (i), the
1322 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1323 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1324       do i=1,nres-1
1325 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1326           if (i.eq.nres-1) then
1327 C Case of the last full residue
1328 C Compute the Z-axis
1329             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1330             costh=dcos(pi-theta(nres))
1331             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1332             do k=1,3
1333               uz(k,i)=fac*uz(k,i)
1334             enddo
1335             if (calc_grad) then
1336 C Compute the derivatives of uz
1337             uzder(1,1,1)= 0.0d0
1338             uzder(2,1,1)=-dc_norm(3,i-1)
1339             uzder(3,1,1)= dc_norm(2,i-1)
1340             uzder(1,2,1)= dc_norm(3,i-1)
1341             uzder(2,2,1)= 0.0d0
1342             uzder(3,2,1)=-dc_norm(1,i-1)
1343             uzder(1,3,1)=-dc_norm(2,i-1)
1344             uzder(2,3,1)= dc_norm(1,i-1)
1345             uzder(3,3,1)= 0.0d0
1346             uzder(1,1,2)= 0.0d0
1347             uzder(2,1,2)= dc_norm(3,i)
1348             uzder(3,1,2)=-dc_norm(2,i)
1349             uzder(1,2,2)=-dc_norm(3,i)
1350             uzder(2,2,2)= 0.0d0
1351             uzder(3,2,2)= dc_norm(1,i)
1352             uzder(1,3,2)= dc_norm(2,i)
1353             uzder(2,3,2)=-dc_norm(1,i)
1354             uzder(3,3,2)= 0.0d0
1355             endif
1356 C Compute the Y-axis
1357             facy=fac
1358             do k=1,3
1359               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1360             enddo
1361             if (calc_grad) then
1362 C Compute the derivatives of uy
1363             do j=1,3
1364               do k=1,3
1365                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1366      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1367                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1368               enddo
1369               uyder(j,j,1)=uyder(j,j,1)-costh
1370               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1371             enddo
1372             do j=1,2
1373               do k=1,3
1374                 do l=1,3
1375                   uygrad(l,k,j,i)=uyder(l,k,j)
1376                   uzgrad(l,k,j,i)=uzder(l,k,j)
1377                 enddo
1378               enddo
1379             enddo
1380             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1381             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1382             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1383             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1384             endif
1385           else
1386 C Other residues
1387 C Compute the Z-axis
1388             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1389             costh=dcos(pi-theta(i+2))
1390             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1391             do k=1,3
1392               uz(k,i)=fac*uz(k,i)
1393             enddo
1394             if (calc_grad) then
1395 C Compute the derivatives of uz
1396             uzder(1,1,1)= 0.0d0
1397             uzder(2,1,1)=-dc_norm(3,i+1)
1398             uzder(3,1,1)= dc_norm(2,i+1)
1399             uzder(1,2,1)= dc_norm(3,i+1)
1400             uzder(2,2,1)= 0.0d0
1401             uzder(3,2,1)=-dc_norm(1,i+1)
1402             uzder(1,3,1)=-dc_norm(2,i+1)
1403             uzder(2,3,1)= dc_norm(1,i+1)
1404             uzder(3,3,1)= 0.0d0
1405             uzder(1,1,2)= 0.0d0
1406             uzder(2,1,2)= dc_norm(3,i)
1407             uzder(3,1,2)=-dc_norm(2,i)
1408             uzder(1,2,2)=-dc_norm(3,i)
1409             uzder(2,2,2)= 0.0d0
1410             uzder(3,2,2)= dc_norm(1,i)
1411             uzder(1,3,2)= dc_norm(2,i)
1412             uzder(2,3,2)=-dc_norm(1,i)
1413             uzder(3,3,2)= 0.0d0
1414             endif
1415 C Compute the Y-axis
1416             facy=fac
1417             do k=1,3
1418               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1419             enddo
1420             if (calc_grad) then
1421 C Compute the derivatives of uy
1422             do j=1,3
1423               do k=1,3
1424                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1425      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1426                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1427               enddo
1428               uyder(j,j,1)=uyder(j,j,1)-costh
1429               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1430             enddo
1431             do j=1,2
1432               do k=1,3
1433                 do l=1,3
1434                   uygrad(l,k,j,i)=uyder(l,k,j)
1435                   uzgrad(l,k,j,i)=uzder(l,k,j)
1436                 enddo
1437               enddo
1438             enddo
1439             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1440             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1441             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1442             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1443           endif
1444           endif
1445       enddo
1446       if (calc_grad) then
1447       do i=1,nres-1
1448         vbld_inv_temp(1)=vbld_inv(i+1)
1449         if (i.lt.nres-1) then
1450           vbld_inv_temp(2)=vbld_inv(i+2)
1451         else
1452           vbld_inv_temp(2)=vbld_inv(i)
1453         endif
1454         do j=1,2
1455           do k=1,3
1456             do l=1,3
1457               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1458               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1459             enddo
1460           enddo
1461         enddo
1462       enddo
1463       endif
1464       return
1465       end
1466 C-----------------------------------------------------------------------------
1467       subroutine vec_and_deriv_test
1468       implicit real*8 (a-h,o-z)
1469       include 'DIMENSIONS'
1470       include 'DIMENSIONS.ZSCOPT'
1471       include 'COMMON.IOUNITS'
1472       include 'COMMON.GEO'
1473       include 'COMMON.VAR'
1474       include 'COMMON.LOCAL'
1475       include 'COMMON.CHAIN'
1476       include 'COMMON.VECTORS'
1477       dimension uyder(3,3,2),uzder(3,3,2)
1478 C Compute the local reference systems. For reference system (i), the
1479 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1480 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1481       do i=1,nres-1
1482           if (i.eq.nres-1) then
1483 C Case of the last full residue
1484 C Compute the Z-axis
1485             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1486             costh=dcos(pi-theta(nres))
1487             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1488 c            write (iout,*) 'fac',fac,
1489 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1490             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1491             do k=1,3
1492               uz(k,i)=fac*uz(k,i)
1493             enddo
1494 C Compute the derivatives of uz
1495             uzder(1,1,1)= 0.0d0
1496             uzder(2,1,1)=-dc_norm(3,i-1)
1497             uzder(3,1,1)= dc_norm(2,i-1)
1498             uzder(1,2,1)= dc_norm(3,i-1)
1499             uzder(2,2,1)= 0.0d0
1500             uzder(3,2,1)=-dc_norm(1,i-1)
1501             uzder(1,3,1)=-dc_norm(2,i-1)
1502             uzder(2,3,1)= dc_norm(1,i-1)
1503             uzder(3,3,1)= 0.0d0
1504             uzder(1,1,2)= 0.0d0
1505             uzder(2,1,2)= dc_norm(3,i)
1506             uzder(3,1,2)=-dc_norm(2,i)
1507             uzder(1,2,2)=-dc_norm(3,i)
1508             uzder(2,2,2)= 0.0d0
1509             uzder(3,2,2)= dc_norm(1,i)
1510             uzder(1,3,2)= dc_norm(2,i)
1511             uzder(2,3,2)=-dc_norm(1,i)
1512             uzder(3,3,2)= 0.0d0
1513 C Compute the Y-axis
1514             do k=1,3
1515               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1516             enddo
1517             facy=fac
1518             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1519      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1520      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1521             do k=1,3
1522 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1523               uy(k,i)=
1524 c     &        facy*(
1525      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1526      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1527 c     &        )
1528             enddo
1529 c            write (iout,*) 'facy',facy,
1530 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1531             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1532             do k=1,3
1533               uy(k,i)=facy*uy(k,i)
1534             enddo
1535 C Compute the derivatives of uy
1536             do j=1,3
1537               do k=1,3
1538                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1539      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1540                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1541               enddo
1542 c              uyder(j,j,1)=uyder(j,j,1)-costh
1543 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1544               uyder(j,j,1)=uyder(j,j,1)
1545      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1546               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1547      &          +uyder(j,j,2)
1548             enddo
1549             do j=1,2
1550               do k=1,3
1551                 do l=1,3
1552                   uygrad(l,k,j,i)=uyder(l,k,j)
1553                   uzgrad(l,k,j,i)=uzder(l,k,j)
1554                 enddo
1555               enddo
1556             enddo
1557             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1558             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1559             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1560             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1561           else
1562 C Other residues
1563 C Compute the Z-axis
1564             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1565             costh=dcos(pi-theta(i+2))
1566             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1567             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1568             do k=1,3
1569               uz(k,i)=fac*uz(k,i)
1570             enddo
1571 C Compute the derivatives of uz
1572             uzder(1,1,1)= 0.0d0
1573             uzder(2,1,1)=-dc_norm(3,i+1)
1574             uzder(3,1,1)= dc_norm(2,i+1)
1575             uzder(1,2,1)= dc_norm(3,i+1)
1576             uzder(2,2,1)= 0.0d0
1577             uzder(3,2,1)=-dc_norm(1,i+1)
1578             uzder(1,3,1)=-dc_norm(2,i+1)
1579             uzder(2,3,1)= dc_norm(1,i+1)
1580             uzder(3,3,1)= 0.0d0
1581             uzder(1,1,2)= 0.0d0
1582             uzder(2,1,2)= dc_norm(3,i)
1583             uzder(3,1,2)=-dc_norm(2,i)
1584             uzder(1,2,2)=-dc_norm(3,i)
1585             uzder(2,2,2)= 0.0d0
1586             uzder(3,2,2)= dc_norm(1,i)
1587             uzder(1,3,2)= dc_norm(2,i)
1588             uzder(2,3,2)=-dc_norm(1,i)
1589             uzder(3,3,2)= 0.0d0
1590 C Compute the Y-axis
1591             facy=fac
1592             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1593      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1594      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1595             do k=1,3
1596 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1597               uy(k,i)=
1598 c     &        facy*(
1599      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1600      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1601 c     &        )
1602             enddo
1603 c            write (iout,*) 'facy',facy,
1604 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1605             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1606             do k=1,3
1607               uy(k,i)=facy*uy(k,i)
1608             enddo
1609 C Compute the derivatives of uy
1610             do j=1,3
1611               do k=1,3
1612                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1613      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1614                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1615               enddo
1616 c              uyder(j,j,1)=uyder(j,j,1)-costh
1617 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1618               uyder(j,j,1)=uyder(j,j,1)
1619      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1620               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1621      &          +uyder(j,j,2)
1622             enddo
1623             do j=1,2
1624               do k=1,3
1625                 do l=1,3
1626                   uygrad(l,k,j,i)=uyder(l,k,j)
1627                   uzgrad(l,k,j,i)=uzder(l,k,j)
1628                 enddo
1629               enddo
1630             enddo
1631             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1632             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1633             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1634             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1635           endif
1636       enddo
1637       do i=1,nres-1
1638         do j=1,2
1639           do k=1,3
1640             do l=1,3
1641               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1642               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1643             enddo
1644           enddo
1645         enddo
1646       enddo
1647       return
1648       end
1649 C-----------------------------------------------------------------------------
1650       subroutine check_vecgrad
1651       implicit real*8 (a-h,o-z)
1652       include 'DIMENSIONS'
1653       include 'DIMENSIONS.ZSCOPT'
1654       include 'COMMON.IOUNITS'
1655       include 'COMMON.GEO'
1656       include 'COMMON.VAR'
1657       include 'COMMON.LOCAL'
1658       include 'COMMON.CHAIN'
1659       include 'COMMON.VECTORS'
1660       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1661       dimension uyt(3,maxres),uzt(3,maxres)
1662       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1663       double precision delta /1.0d-7/
1664       call vec_and_deriv
1665 cd      do i=1,nres
1666 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1667 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1668 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1669 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1670 cd     &     (dc_norm(if90,i),if90=1,3)
1671 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1672 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1673 cd          write(iout,'(a)')
1674 cd      enddo
1675       do i=1,nres
1676         do j=1,2
1677           do k=1,3
1678             do l=1,3
1679               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1680               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1681             enddo
1682           enddo
1683         enddo
1684       enddo
1685       call vec_and_deriv
1686       do i=1,nres
1687         do j=1,3
1688           uyt(j,i)=uy(j,i)
1689           uzt(j,i)=uz(j,i)
1690         enddo
1691       enddo
1692       do i=1,nres
1693 cd        write (iout,*) 'i=',i
1694         do k=1,3
1695           erij(k)=dc_norm(k,i)
1696         enddo
1697         do j=1,3
1698           do k=1,3
1699             dc_norm(k,i)=erij(k)
1700           enddo
1701           dc_norm(j,i)=dc_norm(j,i)+delta
1702 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1703 c          do k=1,3
1704 c            dc_norm(k,i)=dc_norm(k,i)/fac
1705 c          enddo
1706 c          write (iout,*) (dc_norm(k,i),k=1,3)
1707 c          write (iout,*) (erij(k),k=1,3)
1708           call vec_and_deriv
1709           do k=1,3
1710             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1711             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1712             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1713             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1714           enddo
1715 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1716 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1717 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1718         enddo
1719         do k=1,3
1720           dc_norm(k,i)=erij(k)
1721         enddo
1722 cd        do k=1,3
1723 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1724 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1725 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1726 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1727 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1728 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1729 cd          write (iout,'(a)')
1730 cd        enddo
1731       enddo
1732       return
1733       end
1734 C--------------------------------------------------------------------------
1735       subroutine set_matrices
1736       implicit real*8 (a-h,o-z)
1737       include 'DIMENSIONS'
1738       include 'DIMENSIONS.ZSCOPT'
1739       include 'COMMON.IOUNITS'
1740       include 'COMMON.GEO'
1741       include 'COMMON.VAR'
1742       include 'COMMON.LOCAL'
1743       include 'COMMON.CHAIN'
1744       include 'COMMON.DERIV'
1745       include 'COMMON.INTERACT'
1746       include 'COMMON.CONTACTS'
1747       include 'COMMON.TORSION'
1748       include 'COMMON.VECTORS'
1749       include 'COMMON.FFIELD'
1750       double precision auxvec(2),auxmat(2,2)
1751 C
1752 C Compute the virtual-bond-torsional-angle dependent quantities needed
1753 C to calculate the el-loc multibody terms of various order.
1754 C
1755       do i=3,nres+1
1756         if (i .lt. nres+1) then
1757           sin1=dsin(phi(i))
1758           cos1=dcos(phi(i))
1759           sintab(i-2)=sin1
1760           costab(i-2)=cos1
1761           obrot(1,i-2)=cos1
1762           obrot(2,i-2)=sin1
1763           sin2=dsin(2*phi(i))
1764           cos2=dcos(2*phi(i))
1765           sintab2(i-2)=sin2
1766           costab2(i-2)=cos2
1767           obrot2(1,i-2)=cos2
1768           obrot2(2,i-2)=sin2
1769           Ug(1,1,i-2)=-cos1
1770           Ug(1,2,i-2)=-sin1
1771           Ug(2,1,i-2)=-sin1
1772           Ug(2,2,i-2)= cos1
1773           Ug2(1,1,i-2)=-cos2
1774           Ug2(1,2,i-2)=-sin2
1775           Ug2(2,1,i-2)=-sin2
1776           Ug2(2,2,i-2)= cos2
1777         else
1778           costab(i-2)=1.0d0
1779           sintab(i-2)=0.0d0
1780           obrot(1,i-2)=1.0d0
1781           obrot(2,i-2)=0.0d0
1782           obrot2(1,i-2)=0.0d0
1783           obrot2(2,i-2)=0.0d0
1784           Ug(1,1,i-2)=1.0d0
1785           Ug(1,2,i-2)=0.0d0
1786           Ug(2,1,i-2)=0.0d0
1787           Ug(2,2,i-2)=1.0d0
1788           Ug2(1,1,i-2)=0.0d0
1789           Ug2(1,2,i-2)=0.0d0
1790           Ug2(2,1,i-2)=0.0d0
1791           Ug2(2,2,i-2)=0.0d0
1792         endif
1793         if (i .gt. 3 .and. i .lt. nres+1) then
1794           obrot_der(1,i-2)=-sin1
1795           obrot_der(2,i-2)= cos1
1796           Ugder(1,1,i-2)= sin1
1797           Ugder(1,2,i-2)=-cos1
1798           Ugder(2,1,i-2)=-cos1
1799           Ugder(2,2,i-2)=-sin1
1800           dwacos2=cos2+cos2
1801           dwasin2=sin2+sin2
1802           obrot2_der(1,i-2)=-dwasin2
1803           obrot2_der(2,i-2)= dwacos2
1804           Ug2der(1,1,i-2)= dwasin2
1805           Ug2der(1,2,i-2)=-dwacos2
1806           Ug2der(2,1,i-2)=-dwacos2
1807           Ug2der(2,2,i-2)=-dwasin2
1808         else
1809           obrot_der(1,i-2)=0.0d0
1810           obrot_der(2,i-2)=0.0d0
1811           Ugder(1,1,i-2)=0.0d0
1812           Ugder(1,2,i-2)=0.0d0
1813           Ugder(2,1,i-2)=0.0d0
1814           Ugder(2,2,i-2)=0.0d0
1815           obrot2_der(1,i-2)=0.0d0
1816           obrot2_der(2,i-2)=0.0d0
1817           Ug2der(1,1,i-2)=0.0d0
1818           Ug2der(1,2,i-2)=0.0d0
1819           Ug2der(2,1,i-2)=0.0d0
1820           Ug2der(2,2,i-2)=0.0d0
1821         endif
1822         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1823           if (itype(i-2).le.ntyp) then
1824             iti = itortyp(itype(i-2))
1825           else
1826             iti=ntortyp+1
1827           endif
1828         else
1829           iti=ntortyp+1
1830         endif
1831         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1832           if (itype(i-1).le.ntyp) then
1833             iti1 = itortyp(itype(i-1))
1834           else
1835             iti1=ntortyp+1
1836           endif
1837         else
1838           iti1=ntortyp+1
1839         endif
1840 cd        write (iout,*) '*******i',i,' iti1',iti
1841 cd        write (iout,*) 'b1',b1(:,iti)
1842 cd        write (iout,*) 'b2',b2(:,iti)
1843 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1844 c        print *,"itilde1 i iti iti1",i,iti,iti1
1845         if (i .gt. iatel_s+2) then
1846           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
1847           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
1848           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
1849           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
1850           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1851           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
1852           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
1853         else
1854           do k=1,2
1855             Ub2(k,i-2)=0.0d0
1856             Ctobr(k,i-2)=0.0d0
1857             Dtobr2(k,i-2)=0.0d0
1858             do l=1,2
1859               EUg(l,k,i-2)=0.0d0
1860               CUg(l,k,i-2)=0.0d0
1861               DUg(l,k,i-2)=0.0d0
1862               DtUg2(l,k,i-2)=0.0d0
1863             enddo
1864           enddo
1865         endif
1866 c        print *,"itilde2 i iti iti1",i,iti,iti1
1867         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
1868         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
1869         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1870         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
1871         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1872         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
1873         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1874 c        print *,"itilde3 i iti iti1",i,iti,iti1
1875         do k=1,2
1876           muder(k,i-2)=Ub2der(k,i-2)
1877         enddo
1878         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1879           if (itype(i-1).le.ntyp) then
1880             iti1 = itortyp(itype(i-1))
1881           else
1882             iti1=ntortyp+1
1883           endif
1884         else
1885           iti1=ntortyp+1
1886         endif
1887         do k=1,2
1888           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
1889         enddo
1890 C Vectors and matrices dependent on a single virtual-bond dihedral.
1891         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
1892         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1893         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1894         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
1895         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
1896         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
1897         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
1898         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
1899         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
1900 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
1901 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
1902       enddo
1903 C Matrices dependent on two consecutive virtual-bond dihedrals.
1904 C The order of matrices is from left to right.
1905       do i=2,nres-1
1906         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1907         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1908         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1909         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1910         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1911         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1912         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1913         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
1914       enddo
1915 cd      do i=1,nres
1916 cd        iti = itortyp(itype(i))
1917 cd        write (iout,*) i
1918 cd        do j=1,2
1919 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
1920 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
1921 cd        enddo
1922 cd      enddo
1923       return
1924       end
1925 C--------------------------------------------------------------------------
1926       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
1927 C
1928 C This subroutine calculates the average interaction energy and its gradient
1929 C in the virtual-bond vectors between non-adjacent peptide groups, based on
1930 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
1931 C The potential depends both on the distance of peptide-group centers and on
1932 C the orientation of the CA-CA virtual bonds.
1933 C
1934       implicit real*8 (a-h,o-z)
1935       include 'DIMENSIONS'
1936       include 'DIMENSIONS.ZSCOPT'
1937       include 'DIMENSIONS.FREE'
1938       include 'COMMON.CONTROL'
1939       include 'COMMON.IOUNITS'
1940       include 'COMMON.GEO'
1941       include 'COMMON.VAR'
1942       include 'COMMON.LOCAL'
1943       include 'COMMON.CHAIN'
1944       include 'COMMON.DERIV'
1945       include 'COMMON.INTERACT'
1946       include 'COMMON.CONTACTS'
1947       include 'COMMON.TORSION'
1948       include 'COMMON.VECTORS'
1949       include 'COMMON.FFIELD'
1950       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
1951      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
1952       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
1953      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
1954       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
1955 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
1956       double precision scal_el /0.5d0/
1957 C 12/13/98
1958 C 13-go grudnia roku pamietnego...
1959       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
1960      &                   0.0d0,1.0d0,0.0d0,
1961      &                   0.0d0,0.0d0,1.0d0/
1962 cd      write(iout,*) 'In EELEC'
1963 cd      do i=1,nloctyp
1964 cd        write(iout,*) 'Type',i
1965 cd        write(iout,*) 'B1',B1(:,i)
1966 cd        write(iout,*) 'B2',B2(:,i)
1967 cd        write(iout,*) 'CC',CC(:,:,i)
1968 cd        write(iout,*) 'DD',DD(:,:,i)
1969 cd        write(iout,*) 'EE',EE(:,:,i)
1970 cd      enddo
1971 cd      call check_vecgrad
1972 cd      stop
1973       if (icheckgrad.eq.1) then
1974         do i=1,nres-1
1975           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
1976           do k=1,3
1977             dc_norm(k,i)=dc(k,i)*fac
1978           enddo
1979 c          write (iout,*) 'i',i,' fac',fac
1980         enddo
1981       endif
1982       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
1983      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
1984      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
1985 cd      if (wel_loc.gt.0.0d0) then
1986         if (icheckgrad.eq.1) then
1987         call vec_and_deriv_test
1988         else
1989         call vec_and_deriv
1990         endif
1991         call set_matrices
1992       endif
1993 cd      do i=1,nres-1
1994 cd        write (iout,*) 'i=',i
1995 cd        do k=1,3
1996 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
1997 cd        enddo
1998 cd        do k=1,3
1999 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2000 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2001 cd        enddo
2002 cd      enddo
2003       num_conti_hb=0
2004       ees=0.0D0
2005       evdw1=0.0D0
2006       eel_loc=0.0d0
2007       eello_turn3=0.0d0
2008       eello_turn4=0.0d0
2009       ind=0
2010       do i=1,nres
2011         num_cont_hb(i)=0
2012       enddo
2013 cd      print '(a)','Enter EELEC'
2014 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2015       do i=1,nres
2016         gel_loc_loc(i)=0.0d0
2017         gcorr_loc(i)=0.0d0
2018       enddo
2019       do i=iatel_s,iatel_e
2020 cAna           if (i.le.1) cycle
2021            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2022 cAna     &  .or. ((i+2).gt.nres)
2023 cAna     &  .or. ((i-1).le.0)
2024 cAna     &  .or. itype(i+2).eq.ntyp1
2025 cAna     &  .or. itype(i-1).eq.ntyp1
2026      &) cycle
2027 C         endif
2028         if (itel(i).eq.0) goto 1215
2029         dxi=dc(1,i)
2030         dyi=dc(2,i)
2031         dzi=dc(3,i)
2032         dx_normi=dc_norm(1,i)
2033         dy_normi=dc_norm(2,i)
2034         dz_normi=dc_norm(3,i)
2035         xmedi=c(1,i)+0.5d0*dxi
2036         ymedi=c(2,i)+0.5d0*dyi
2037         zmedi=c(3,i)+0.5d0*dzi
2038           xmedi=mod(xmedi,boxxsize)
2039           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2040           ymedi=mod(ymedi,boxysize)
2041           if (ymedi.lt.0) ymedi=ymedi+boxysize
2042           zmedi=mod(zmedi,boxzsize)
2043           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2044         num_conti=0
2045 C        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2046         do j=ielstart(i),ielend(i)
2047 cAna          if (j.le.1) cycle
2048           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2049 cAna     & .or.((j+2).gt.nres)
2050 cAna     & .or.((j-1).le.0)
2051 cAna     & .or.itype(j+2).eq.ntyp1
2052 cAna     & .or.itype(j-1).eq.ntyp1
2053      &) cycle
2054           if (itel(j).eq.0) goto 1216
2055           ind=ind+1
2056           iteli=itel(i)
2057           itelj=itel(j)
2058           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2059           aaa=app(iteli,itelj)
2060           bbb=bpp(iteli,itelj)
2061 C Diagnostics only!!!
2062 c         aaa=0.0D0
2063 c         bbb=0.0D0
2064 c         ael6i=0.0D0
2065 c         ael3i=0.0D0
2066 C End diagnostics
2067           ael6i=ael6(iteli,itelj)
2068           ael3i=ael3(iteli,itelj)
2069           dxj=dc(1,j)
2070           dyj=dc(2,j)
2071           dzj=dc(3,j)
2072           dx_normj=dc_norm(1,j)
2073           dy_normj=dc_norm(2,j)
2074           dz_normj=dc_norm(3,j)
2075           xj=c(1,j)+0.5D0*dxj
2076           yj=c(2,j)+0.5D0*dyj
2077           zj=c(3,j)+0.5D0*dzj
2078          xj=mod(xj,boxxsize)
2079           if (xj.lt.0) xj=xj+boxxsize
2080           yj=mod(yj,boxysize)
2081           if (yj.lt.0) yj=yj+boxysize
2082           zj=mod(zj,boxzsize)
2083           if (zj.lt.0) zj=zj+boxzsize
2084       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2085       xj_safe=xj
2086       yj_safe=yj
2087       zj_safe=zj
2088       isubchap=0
2089       do xshift=-1,1
2090       do yshift=-1,1
2091       do zshift=-1,1
2092           xj=xj_safe+xshift*boxxsize
2093           yj=yj_safe+yshift*boxysize
2094           zj=zj_safe+zshift*boxzsize
2095           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2096           if(dist_temp.lt.dist_init) then
2097             dist_init=dist_temp
2098             xj_temp=xj
2099             yj_temp=yj
2100             zj_temp=zj
2101             isubchap=1
2102           endif
2103        enddo
2104        enddo
2105        enddo
2106        if (isubchap.eq.1) then
2107           xj=xj_temp-xmedi
2108           yj=yj_temp-ymedi
2109           zj=zj_temp-zmedi
2110        else
2111           xj=xj_safe-xmedi
2112           yj=yj_safe-ymedi
2113           zj=zj_safe-zmedi
2114        endif
2115           rij=xj*xj+yj*yj+zj*zj
2116             sss=sscale(sqrt(rij))
2117             sssgrad=sscagrad(sqrt(rij))
2118           rrmij=1.0D0/rij
2119           rij=dsqrt(rij)
2120           rmij=1.0D0/rij
2121           r3ij=rrmij*rmij
2122           r6ij=r3ij*r3ij
2123           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2124           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2125           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2126           fac=cosa-3.0D0*cosb*cosg
2127           ev1=aaa*r6ij*r6ij
2128 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2129           if (j.eq.i+2) ev1=scal_el*ev1
2130           ev2=bbb*r6ij
2131           fac3=ael6i*r6ij
2132           fac4=ael3i*r3ij
2133           evdwij=ev1+ev2
2134           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2135           el2=fac4*fac
2136           eesij=el1+el2
2137 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2138 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2139           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2140           ees=ees+eesij
2141           evdw1=evdw1+evdwij*sss
2142 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2143 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2144 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2145 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2146 C
2147 C Calculate contributions to the Cartesian gradient.
2148 C
2149 #ifdef SPLITELE
2150           facvdw=-6*rrmij*(ev1+evdwij)*sss
2151           facel=-3*rrmij*(el1+eesij)
2152           fac1=fac
2153           erij(1)=xj*rmij
2154           erij(2)=yj*rmij
2155           erij(3)=zj*rmij
2156           if (calc_grad) then
2157 *
2158 * Radial derivatives. First process both termini of the fragment (i,j)
2159 *
2160           ggg(1)=facel*xj
2161           ggg(2)=facel*yj
2162           ggg(3)=facel*zj
2163           do k=1,3
2164             ghalf=0.5D0*ggg(k)
2165             gelc(k,i)=gelc(k,i)+ghalf
2166             gelc(k,j)=gelc(k,j)+ghalf
2167           enddo
2168 *
2169 * Loop over residues i+1 thru j-1.
2170 *
2171           do k=i+1,j-1
2172             do l=1,3
2173               gelc(l,k)=gelc(l,k)+ggg(l)
2174             enddo
2175           enddo
2176           ggg(1)=facvdw*xj
2177           ggg(2)=facvdw*yj
2178           ggg(3)=facvdw*zj
2179           do k=1,3
2180             ghalf=0.5D0*ggg(k)
2181             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2182             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2183           enddo
2184 *
2185 * Loop over residues i+1 thru j-1.
2186 *
2187           do k=i+1,j-1
2188             do l=1,3
2189               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2190             enddo
2191           enddo
2192 #else
2193           facvdw=ev1+evdwij
2194           facel=el1+eesij
2195           fac1=fac
2196           fac=-3*rrmij*(facvdw+facvdw+facel)
2197           erij(1)=xj*rmij
2198           erij(2)=yj*rmij
2199           erij(3)=zj*rmij
2200           if (calc_grad) then
2201 *
2202 * Radial derivatives. First process both termini of the fragment (i,j)
2203 *
2204           ggg(1)=fac*xj
2205           ggg(2)=fac*yj
2206           ggg(3)=fac*zj
2207           do k=1,3
2208             ghalf=0.5D0*ggg(k)
2209             gelc(k,i)=gelc(k,i)+ghalf
2210             gelc(k,j)=gelc(k,j)+ghalf
2211           enddo
2212 *
2213 * Loop over residues i+1 thru j-1.
2214 *
2215           do k=i+1,j-1
2216             do l=1,3
2217               gelc(l,k)=gelc(l,k)+ggg(l)
2218             enddo
2219           enddo
2220 #endif
2221 *
2222 * Angular part
2223 *
2224           ecosa=2.0D0*fac3*fac1+fac4
2225           fac4=-3.0D0*fac4
2226           fac3=-6.0D0*fac3
2227           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2228           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2229           do k=1,3
2230             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2231             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2232           enddo
2233 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2234 cd   &          (dcosg(k),k=1,3)
2235           do k=1,3
2236             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2237           enddo
2238           do k=1,3
2239             ghalf=0.5D0*ggg(k)
2240             gelc(k,i)=gelc(k,i)+ghalf
2241      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2242      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2243             gelc(k,j)=gelc(k,j)+ghalf
2244      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2245      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2246           enddo
2247           do k=i+1,j-1
2248             do l=1,3
2249               gelc(l,k)=gelc(l,k)+ggg(l)
2250             enddo
2251           enddo
2252           endif
2253
2254           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2255      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2256      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2257 C
2258 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2259 C   energy of a peptide unit is assumed in the form of a second-order
2260 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2261 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2262 C   are computed for EVERY pair of non-contiguous peptide groups.
2263 C
2264           if (j.lt.nres-1) then
2265             j1=j+1
2266             j2=j-1
2267           else
2268             j1=j-1
2269             j2=j-2
2270           endif
2271           kkk=0
2272           do k=1,2
2273             do l=1,2
2274               kkk=kkk+1
2275               muij(kkk)=mu(k,i)*mu(l,j)
2276             enddo
2277           enddo
2278 cd         write (iout,*) 'EELEC: i',i,' j',j
2279 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2280 cd          write(iout,*) 'muij',muij
2281           ury=scalar(uy(1,i),erij)
2282           urz=scalar(uz(1,i),erij)
2283           vry=scalar(uy(1,j),erij)
2284           vrz=scalar(uz(1,j),erij)
2285           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2286           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2287           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2288           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2289 C For diagnostics only
2290 cd          a22=1.0d0
2291 cd          a23=1.0d0
2292 cd          a32=1.0d0
2293 cd          a33=1.0d0
2294           fac=dsqrt(-ael6i)*r3ij
2295 cd          write (2,*) 'fac=',fac
2296 C For diagnostics only
2297 cd          fac=1.0d0
2298           a22=a22*fac
2299           a23=a23*fac
2300           a32=a32*fac
2301           a33=a33*fac
2302 cd          write (iout,'(4i5,4f10.5)')
2303 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2304 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2305 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2306 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2307 cd          write (iout,'(4f10.5)')
2308 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2309 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2310 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2311 cd           write (iout,'(2i3,9f10.5/)') i,j,
2312 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2313           if (calc_grad) then
2314 C Derivatives of the elements of A in virtual-bond vectors
2315           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2316 cd          do k=1,3
2317 cd            do l=1,3
2318 cd              erder(k,l)=0.0d0
2319 cd            enddo
2320 cd          enddo
2321           do k=1,3
2322             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2323             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2324             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2325             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2326             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2327             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2328             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2329             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2330             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2331             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2332             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2333             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2334           enddo
2335 cd          do k=1,3
2336 cd            do l=1,3
2337 cd              uryg(k,l)=0.0d0
2338 cd              urzg(k,l)=0.0d0
2339 cd              vryg(k,l)=0.0d0
2340 cd              vrzg(k,l)=0.0d0
2341 cd            enddo
2342 cd          enddo
2343 C Compute radial contributions to the gradient
2344           facr=-3.0d0*rrmij
2345           a22der=a22*facr
2346           a23der=a23*facr
2347           a32der=a32*facr
2348           a33der=a33*facr
2349 cd          a22der=0.0d0
2350 cd          a23der=0.0d0
2351 cd          a32der=0.0d0
2352 cd          a33der=0.0d0
2353           agg(1,1)=a22der*xj
2354           agg(2,1)=a22der*yj
2355           agg(3,1)=a22der*zj
2356           agg(1,2)=a23der*xj
2357           agg(2,2)=a23der*yj
2358           agg(3,2)=a23der*zj
2359           agg(1,3)=a32der*xj
2360           agg(2,3)=a32der*yj
2361           agg(3,3)=a32der*zj
2362           agg(1,4)=a33der*xj
2363           agg(2,4)=a33der*yj
2364           agg(3,4)=a33der*zj
2365 C Add the contributions coming from er
2366           fac3=-3.0d0*fac
2367           do k=1,3
2368             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2369             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2370             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2371             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2372           enddo
2373           do k=1,3
2374 C Derivatives in DC(i)
2375             ghalf1=0.5d0*agg(k,1)
2376             ghalf2=0.5d0*agg(k,2)
2377             ghalf3=0.5d0*agg(k,3)
2378             ghalf4=0.5d0*agg(k,4)
2379             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2380      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2381             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2382      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2383             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2384      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2385             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2386      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2387 C Derivatives in DC(i+1)
2388             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2389      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2390             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2391      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2392             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2393      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2394             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2395      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2396 C Derivatives in DC(j)
2397             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2398      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2399             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2400      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2401             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2402      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2403             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2404      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2405 C Derivatives in DC(j+1) or DC(nres-1)
2406             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2407      &      -3.0d0*vryg(k,3)*ury)
2408             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2409      &      -3.0d0*vrzg(k,3)*ury)
2410             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2411      &      -3.0d0*vryg(k,3)*urz)
2412             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2413      &      -3.0d0*vrzg(k,3)*urz)
2414 cd            aggi(k,1)=ghalf1
2415 cd            aggi(k,2)=ghalf2
2416 cd            aggi(k,3)=ghalf3
2417 cd            aggi(k,4)=ghalf4
2418 C Derivatives in DC(i+1)
2419 cd            aggi1(k,1)=agg(k,1)
2420 cd            aggi1(k,2)=agg(k,2)
2421 cd            aggi1(k,3)=agg(k,3)
2422 cd            aggi1(k,4)=agg(k,4)
2423 C Derivatives in DC(j)
2424 cd            aggj(k,1)=ghalf1
2425 cd            aggj(k,2)=ghalf2
2426 cd            aggj(k,3)=ghalf3
2427 cd            aggj(k,4)=ghalf4
2428 C Derivatives in DC(j+1)
2429 cd            aggj1(k,1)=0.0d0
2430 cd            aggj1(k,2)=0.0d0
2431 cd            aggj1(k,3)=0.0d0
2432 cd            aggj1(k,4)=0.0d0
2433             if (j.eq.nres-1 .and. i.lt.j-2) then
2434               do l=1,4
2435                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2436 cd                aggj1(k,l)=agg(k,l)
2437               enddo
2438             endif
2439           enddo
2440           endif
2441 c          goto 11111
2442 C Check the loc-el terms by numerical integration
2443           acipa(1,1)=a22
2444           acipa(1,2)=a23
2445           acipa(2,1)=a32
2446           acipa(2,2)=a33
2447           a22=-a22
2448           a23=-a23
2449           do l=1,2
2450             do k=1,3
2451               agg(k,l)=-agg(k,l)
2452               aggi(k,l)=-aggi(k,l)
2453               aggi1(k,l)=-aggi1(k,l)
2454               aggj(k,l)=-aggj(k,l)
2455               aggj1(k,l)=-aggj1(k,l)
2456             enddo
2457           enddo
2458           if (j.lt.nres-1) then
2459             a22=-a22
2460             a32=-a32
2461             do l=1,3,2
2462               do k=1,3
2463                 agg(k,l)=-agg(k,l)
2464                 aggi(k,l)=-aggi(k,l)
2465                 aggi1(k,l)=-aggi1(k,l)
2466                 aggj(k,l)=-aggj(k,l)
2467                 aggj1(k,l)=-aggj1(k,l)
2468               enddo
2469             enddo
2470           else
2471             a22=-a22
2472             a23=-a23
2473             a32=-a32
2474             a33=-a33
2475             do l=1,4
2476               do k=1,3
2477                 agg(k,l)=-agg(k,l)
2478                 aggi(k,l)=-aggi(k,l)
2479                 aggi1(k,l)=-aggi1(k,l)
2480                 aggj(k,l)=-aggj(k,l)
2481                 aggj1(k,l)=-aggj1(k,l)
2482               enddo
2483             enddo
2484           endif
2485           ENDIF ! WCORR
2486 11111     continue
2487           IF (wel_loc.gt.0.0d0) THEN
2488 C Contribution to the local-electrostatic energy coming from the i-j pair
2489           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2490      &     +a33*muij(4)
2491 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2492 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2493           eel_loc=eel_loc+eel_loc_ij
2494 C Partial derivatives in virtual-bond dihedral angles gamma
2495           if (calc_grad) then
2496           if (i.gt.1)
2497      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2498      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2499      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2500           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2501      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2502      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2503 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2504 cd          write(iout,*) 'agg  ',agg
2505 cd          write(iout,*) 'aggi ',aggi
2506 cd          write(iout,*) 'aggi1',aggi1
2507 cd          write(iout,*) 'aggj ',aggj
2508 cd          write(iout,*) 'aggj1',aggj1
2509
2510 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2511           do l=1,3
2512             ggg(l)=agg(l,1)*muij(1)+
2513      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2514           enddo
2515           do k=i+2,j2
2516             do l=1,3
2517               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2518             enddo
2519           enddo
2520 C Remaining derivatives of eello
2521           do l=1,3
2522             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2523      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2524             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2525      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2526             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2527      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2528             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2529      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2530           enddo
2531           endif
2532           ENDIF
2533           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2534 C Contributions from turns
2535             a_temp(1,1)=a22
2536             a_temp(1,2)=a23
2537             a_temp(2,1)=a32
2538             a_temp(2,2)=a33
2539             call eturn34(i,j,eello_turn3,eello_turn4)
2540           endif
2541 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2542           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2543 C
2544 C Calculate the contact function. The ith column of the array JCONT will
2545 C contain the numbers of atoms that make contacts with the atom I (of numbers
2546 C greater than I). The arrays FACONT and GACONT will contain the values of
2547 C the contact function and its derivative.
2548 c           r0ij=1.02D0*rpp(iteli,itelj)
2549 c           r0ij=1.11D0*rpp(iteli,itelj)
2550             r0ij=2.20D0*rpp(iteli,itelj)
2551 c           r0ij=1.55D0*rpp(iteli,itelj)
2552             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2553             if (fcont.gt.0.0D0) then
2554               num_conti=num_conti+1
2555               if (num_conti.gt.maxconts) then
2556                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2557      &                         ' will skip next contacts for this conf.'
2558               else
2559                 jcont_hb(num_conti,i)=j
2560                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2561      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2562 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2563 C  terms.
2564                 d_cont(num_conti,i)=rij
2565 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2566 C     --- Electrostatic-interaction matrix ---
2567                 a_chuj(1,1,num_conti,i)=a22
2568                 a_chuj(1,2,num_conti,i)=a23
2569                 a_chuj(2,1,num_conti,i)=a32
2570                 a_chuj(2,2,num_conti,i)=a33
2571 C     --- Gradient of rij
2572                 do kkk=1,3
2573                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2574                 enddo
2575 c             if (i.eq.1) then
2576 c                a_chuj(1,1,num_conti,i)=-0.61d0
2577 c                a_chuj(1,2,num_conti,i)= 0.4d0
2578 c                a_chuj(2,1,num_conti,i)= 0.65d0
2579 c                a_chuj(2,2,num_conti,i)= 0.50d0
2580 c             else if (i.eq.2) then
2581 c                a_chuj(1,1,num_conti,i)= 0.0d0
2582 c                a_chuj(1,2,num_conti,i)= 0.0d0
2583 c                a_chuj(2,1,num_conti,i)= 0.0d0
2584 c                a_chuj(2,2,num_conti,i)= 0.0d0
2585 c             endif
2586 C     --- and its gradients
2587 cd                write (iout,*) 'i',i,' j',j
2588 cd                do kkk=1,3
2589 cd                write (iout,*) 'iii 1 kkk',kkk
2590 cd                write (iout,*) agg(kkk,:)
2591 cd                enddo
2592 cd                do kkk=1,3
2593 cd                write (iout,*) 'iii 2 kkk',kkk
2594 cd                write (iout,*) aggi(kkk,:)
2595 cd                enddo
2596 cd                do kkk=1,3
2597 cd                write (iout,*) 'iii 3 kkk',kkk
2598 cd                write (iout,*) aggi1(kkk,:)
2599 cd                enddo
2600 cd                do kkk=1,3
2601 cd                write (iout,*) 'iii 4 kkk',kkk
2602 cd                write (iout,*) aggj(kkk,:)
2603 cd                enddo
2604 cd                do kkk=1,3
2605 cd                write (iout,*) 'iii 5 kkk',kkk
2606 cd                write (iout,*) aggj1(kkk,:)
2607 cd                enddo
2608                 kkll=0
2609                 do k=1,2
2610                   do l=1,2
2611                     kkll=kkll+1
2612                     do m=1,3
2613                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2614                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2615                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2616                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2617                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2618 c                      do mm=1,5
2619 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2620 c                      enddo
2621                     enddo
2622                   enddo
2623                 enddo
2624                 ENDIF
2625                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2626 C Calculate contact energies
2627                 cosa4=4.0D0*cosa
2628                 wij=cosa-3.0D0*cosb*cosg
2629                 cosbg1=cosb+cosg
2630                 cosbg2=cosb-cosg
2631 c               fac3=dsqrt(-ael6i)/r0ij**3
2632                 fac3=dsqrt(-ael6i)*r3ij
2633                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2634                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2635 c               ees0mij=0.0D0
2636                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2637                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2638 C Diagnostics. Comment out or remove after debugging!
2639 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2640 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2641 c               ees0m(num_conti,i)=0.0D0
2642 C End diagnostics.
2643 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2644 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2645                 facont_hb(num_conti,i)=fcont
2646                 if (calc_grad) then
2647 C Angular derivatives of the contact function
2648                 ees0pij1=fac3/ees0pij
2649                 ees0mij1=fac3/ees0mij
2650                 fac3p=-3.0D0*fac3*rrmij
2651                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2652                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
2653 c               ees0mij1=0.0D0
2654                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
2655                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
2656                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
2657                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
2658                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
2659                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
2660                 ecosap=ecosa1+ecosa2
2661                 ecosbp=ecosb1+ecosb2
2662                 ecosgp=ecosg1+ecosg2
2663                 ecosam=ecosa1-ecosa2
2664                 ecosbm=ecosb1-ecosb2
2665                 ecosgm=ecosg1-ecosg2
2666 C Diagnostics
2667 c               ecosap=ecosa1
2668 c               ecosbp=ecosb1
2669 c               ecosgp=ecosg1
2670 c               ecosam=0.0D0
2671 c               ecosbm=0.0D0
2672 c               ecosgm=0.0D0
2673 C End diagnostics
2674                 fprimcont=fprimcont/rij
2675 cd              facont_hb(num_conti,i)=1.0D0
2676 C Following line is for diagnostics.
2677 cd              fprimcont=0.0D0
2678                 do k=1,3
2679                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2680                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2681                 enddo
2682                 do k=1,3
2683                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
2684                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
2685                 enddo
2686                 gggp(1)=gggp(1)+ees0pijp*xj
2687                 gggp(2)=gggp(2)+ees0pijp*yj
2688                 gggp(3)=gggp(3)+ees0pijp*zj
2689                 gggm(1)=gggm(1)+ees0mijp*xj
2690                 gggm(2)=gggm(2)+ees0mijp*yj
2691                 gggm(3)=gggm(3)+ees0mijp*zj
2692 C Derivatives due to the contact function
2693                 gacont_hbr(1,num_conti,i)=fprimcont*xj
2694                 gacont_hbr(2,num_conti,i)=fprimcont*yj
2695                 gacont_hbr(3,num_conti,i)=fprimcont*zj
2696                 do k=1,3
2697                   ghalfp=0.5D0*gggp(k)
2698                   ghalfm=0.5D0*gggm(k)
2699                   gacontp_hb1(k,num_conti,i)=ghalfp
2700      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
2701      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2702                   gacontp_hb2(k,num_conti,i)=ghalfp
2703      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
2704      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2705                   gacontp_hb3(k,num_conti,i)=gggp(k)
2706                   gacontm_hb1(k,num_conti,i)=ghalfm
2707      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
2708      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2709                   gacontm_hb2(k,num_conti,i)=ghalfm
2710      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
2711      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2712                   gacontm_hb3(k,num_conti,i)=gggm(k)
2713                 enddo
2714                 endif
2715 C Diagnostics. Comment out or remove after debugging!
2716 cdiag           do k=1,3
2717 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
2718 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
2719 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
2720 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
2721 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
2722 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
2723 cdiag           enddo
2724               ENDIF ! wcorr
2725               endif  ! num_conti.le.maxconts
2726             endif  ! fcont.gt.0
2727           endif    ! j.gt.i+1
2728  1216     continue
2729         enddo ! j
2730         num_cont_hb(i)=num_conti
2731  1215   continue
2732       enddo   ! i
2733 cd      do i=1,nres
2734 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2735 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2736 cd      enddo
2737 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2738 ccc      eel_loc=eel_loc+eello_turn3
2739       return
2740       end
2741 C-----------------------------------------------------------------------------
2742       subroutine eturn34(i,j,eello_turn3,eello_turn4)
2743 C Third- and fourth-order contributions from turns
2744       implicit real*8 (a-h,o-z)
2745       include 'DIMENSIONS'
2746       include 'DIMENSIONS.ZSCOPT'
2747       include 'COMMON.IOUNITS'
2748       include 'COMMON.GEO'
2749       include 'COMMON.VAR'
2750       include 'COMMON.LOCAL'
2751       include 'COMMON.CHAIN'
2752       include 'COMMON.DERIV'
2753       include 'COMMON.INTERACT'
2754       include 'COMMON.CONTACTS'
2755       include 'COMMON.TORSION'
2756       include 'COMMON.VECTORS'
2757       include 'COMMON.FFIELD'
2758       dimension ggg(3)
2759       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
2760      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
2761      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
2762       double precision agg(3,4),aggi(3,4),aggi1(3,4),
2763      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
2764       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
2765       if (j.eq.i+2) then
2766       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2767 C changes suggested by Ana to avoid out of bounds
2768 C     & .or.((i+5).gt.nres)
2769 C     & .or.((i-1).le.0)
2770 C end of changes suggested by Ana
2771      &    .or. itype(i+2).eq.ntyp1
2772      &    .or. itype(i+3).eq.ntyp1
2773 C     &    .or. itype(i+5).eq.ntyp1
2774 C     &    .or. itype(i).eq.ntyp1
2775 C     &    .or. itype(i-1).eq.ntyp1
2776      &    ) goto 179
2777
2778 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2779 C
2780 C               Third-order contributions
2781 C
2782 C                 (i+2)o----(i+3)
2783 C                      | |
2784 C                      | |
2785 C                 (i+1)o----i
2786 C
2787 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2788 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
2789         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
2790         call transpose2(auxmat(1,1),auxmat1(1,1))
2791         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2792         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
2793 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
2794 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
2795 cd     &    ' eello_turn3_num',4*eello_turn3_num
2796         if (calc_grad) then
2797 C Derivatives in gamma(i)
2798         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
2799         call transpose2(auxmat2(1,1),pizda(1,1))
2800         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2801         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
2802 C Derivatives in gamma(i+1)
2803         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
2804         call transpose2(auxmat2(1,1),pizda(1,1))
2805         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
2806         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
2807      &    +0.5d0*(pizda(1,1)+pizda(2,2))
2808 C Cartesian derivatives
2809         do l=1,3
2810           a_temp(1,1)=aggi(l,1)
2811           a_temp(1,2)=aggi(l,2)
2812           a_temp(2,1)=aggi(l,3)
2813           a_temp(2,2)=aggi(l,4)
2814           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2815           gcorr3_turn(l,i)=gcorr3_turn(l,i)
2816      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2817           a_temp(1,1)=aggi1(l,1)
2818           a_temp(1,2)=aggi1(l,2)
2819           a_temp(2,1)=aggi1(l,3)
2820           a_temp(2,2)=aggi1(l,4)
2821           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2822           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
2823      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2824           a_temp(1,1)=aggj(l,1)
2825           a_temp(1,2)=aggj(l,2)
2826           a_temp(2,1)=aggj(l,3)
2827           a_temp(2,2)=aggj(l,4)
2828           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2829           gcorr3_turn(l,j)=gcorr3_turn(l,j)
2830      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2831           a_temp(1,1)=aggj1(l,1)
2832           a_temp(1,2)=aggj1(l,2)
2833           a_temp(2,1)=aggj1(l,3)
2834           a_temp(2,2)=aggj1(l,4)
2835           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
2836           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
2837      &      +0.5d0*(pizda(1,1)+pizda(2,2))
2838         enddo
2839         endif
2840   179 continue
2841       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
2842       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2843 C changes suggested by Ana to avoid out of bounds
2844 C     & .or.((i+5).gt.nres)
2845 C     & .or.((i-1).le.0)
2846 C end of changes suggested by Ana
2847      &    .or. itype(i+3).eq.ntyp1
2848      &    .or. itype(i+4).eq.ntyp1
2849 C     &    .or. itype(i+5).eq.ntyp1
2850      &    .or. itype(i).eq.ntyp1
2851 C     &    .or. itype(i-1).eq.ntyp1
2852      &    ) goto 178
2853 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2854 C
2855 C               Fourth-order contributions
2856 C
2857 C                 (i+3)o----(i+4)
2858 C                     /  |
2859 C               (i+2)o   |
2860 C                     \  |
2861 C                 (i+1)o----i
2862 C
2863 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
2864 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
2865         iti1=itortyp(itype(i+1))
2866         iti2=itortyp(itype(i+2))
2867         iti3=itortyp(itype(i+3))
2868         call transpose2(EUg(1,1,i+1),e1t(1,1))
2869         call transpose2(Eug(1,1,i+2),e2t(1,1))
2870         call transpose2(Eug(1,1,i+3),e3t(1,1))
2871         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2872         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2873         s1=scalar2(b1(1,iti2),auxvec(1))
2874         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2875         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2876         s2=scalar2(b1(1,iti1),auxvec(1))
2877         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2878         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2879         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2880         eello_turn4=eello_turn4-(s1+s2+s3)
2881 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
2882 cd     &    ' eello_turn4_num',8*eello_turn4_num
2883 C Derivatives in gamma(i)
2884         if (calc_grad) then
2885         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
2886         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
2887         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
2888         s1=scalar2(b1(1,iti2),auxvec(1))
2889         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
2890         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2891         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
2892 C Derivatives in gamma(i+1)
2893         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
2894         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
2895         s2=scalar2(b1(1,iti1),auxvec(1))
2896         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
2897         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2898         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2899         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
2900 C Derivatives in gamma(i+2)
2901         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
2902         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
2903         s1=scalar2(b1(1,iti2),auxvec(1))
2904         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
2905         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
2906         s2=scalar2(b1(1,iti1),auxvec(1))
2907         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
2908         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
2909         s3=0.5d0*(pizda(1,1)+pizda(2,2))
2910         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
2911 C Cartesian derivatives
2912 C Derivatives of this turn contributions in DC(i+2)
2913         if (j.lt.nres-1) then
2914           do l=1,3
2915             a_temp(1,1)=agg(l,1)
2916             a_temp(1,2)=agg(l,2)
2917             a_temp(2,1)=agg(l,3)
2918             a_temp(2,2)=agg(l,4)
2919             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2920             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2921             s1=scalar2(b1(1,iti2),auxvec(1))
2922             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2923             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2924             s2=scalar2(b1(1,iti1),auxvec(1))
2925             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2926             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2927             s3=0.5d0*(pizda(1,1)+pizda(2,2))
2928             ggg(l)=-(s1+s2+s3)
2929             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
2930           enddo
2931         endif
2932 C Remaining derivatives of this turn contribution
2933         do l=1,3
2934           a_temp(1,1)=aggi(l,1)
2935           a_temp(1,2)=aggi(l,2)
2936           a_temp(2,1)=aggi(l,3)
2937           a_temp(2,2)=aggi(l,4)
2938           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2939           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2940           s1=scalar2(b1(1,iti2),auxvec(1))
2941           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2942           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2943           s2=scalar2(b1(1,iti1),auxvec(1))
2944           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2945           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2946           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2947           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
2948           a_temp(1,1)=aggi1(l,1)
2949           a_temp(1,2)=aggi1(l,2)
2950           a_temp(2,1)=aggi1(l,3)
2951           a_temp(2,2)=aggi1(l,4)
2952           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2953           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2954           s1=scalar2(b1(1,iti2),auxvec(1))
2955           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2956           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2957           s2=scalar2(b1(1,iti1),auxvec(1))
2958           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2959           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2960           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2961           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
2962           a_temp(1,1)=aggj(l,1)
2963           a_temp(1,2)=aggj(l,2)
2964           a_temp(2,1)=aggj(l,3)
2965           a_temp(2,2)=aggj(l,4)
2966           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2967           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2968           s1=scalar2(b1(1,iti2),auxvec(1))
2969           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2970           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2971           s2=scalar2(b1(1,iti1),auxvec(1))
2972           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2973           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2974           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2975           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
2976           a_temp(1,1)=aggj1(l,1)
2977           a_temp(1,2)=aggj1(l,2)
2978           a_temp(2,1)=aggj1(l,3)
2979           a_temp(2,2)=aggj1(l,4)
2980           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
2981           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
2982           s1=scalar2(b1(1,iti2),auxvec(1))
2983           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
2984           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
2985           s2=scalar2(b1(1,iti1),auxvec(1))
2986           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
2987           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
2988           s3=0.5d0*(pizda(1,1)+pizda(2,2))
2989           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
2990         enddo
2991         endif
2992  178  continue
2993       endif
2994       return
2995       end
2996 C-----------------------------------------------------------------------------
2997       subroutine vecpr(u,v,w)
2998       implicit real*8(a-h,o-z)
2999       dimension u(3),v(3),w(3)
3000       w(1)=u(2)*v(3)-u(3)*v(2)
3001       w(2)=-u(1)*v(3)+u(3)*v(1)
3002       w(3)=u(1)*v(2)-u(2)*v(1)
3003       return
3004       end
3005 C-----------------------------------------------------------------------------
3006       subroutine unormderiv(u,ugrad,unorm,ungrad)
3007 C This subroutine computes the derivatives of a normalized vector u, given
3008 C the derivatives computed without normalization conditions, ugrad. Returns
3009 C ungrad.
3010       implicit none
3011       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3012       double precision vec(3)
3013       double precision scalar
3014       integer i,j
3015 c      write (2,*) 'ugrad',ugrad
3016 c      write (2,*) 'u',u
3017       do i=1,3
3018         vec(i)=scalar(ugrad(1,i),u(1))
3019       enddo
3020 c      write (2,*) 'vec',vec
3021       do i=1,3
3022         do j=1,3
3023           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3024         enddo
3025       enddo
3026 c      write (2,*) 'ungrad',ungrad
3027       return
3028       end
3029 C-----------------------------------------------------------------------------
3030       subroutine escp(evdw2,evdw2_14)
3031 C
3032 C This subroutine calculates the excluded-volume interaction energy between
3033 C peptide-group centers and side chains and its gradient in virtual-bond and
3034 C side-chain vectors.
3035 C
3036       implicit real*8 (a-h,o-z)
3037       include 'DIMENSIONS'
3038       include 'DIMENSIONS.ZSCOPT'
3039       include 'COMMON.GEO'
3040       include 'COMMON.VAR'
3041       include 'COMMON.LOCAL'
3042       include 'COMMON.CHAIN'
3043       include 'COMMON.DERIV'
3044       include 'COMMON.INTERACT'
3045       include 'COMMON.FFIELD'
3046       include 'COMMON.IOUNITS'
3047       dimension ggg(3)
3048       evdw2=0.0D0
3049       evdw2_14=0.0d0
3050 cd    print '(a)','Enter ESCP'
3051 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3052 c     &  ' scal14',scal14
3053       do i=iatscp_s,iatscp_e
3054         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3055         iteli=itel(i)
3056 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3057 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3058         if (iteli.eq.0) goto 1225
3059         xi=0.5D0*(c(1,i)+c(1,i+1))
3060         yi=0.5D0*(c(2,i)+c(2,i+1))
3061         zi=0.5D0*(c(3,i)+c(3,i+1))
3062 C Returning the ith atom to box
3063           xi=mod(xi,boxxsize)
3064           if (xi.lt.0) xi=xi+boxxsize
3065           yi=mod(yi,boxysize)
3066           if (yi.lt.0) yi=yi+boxysize
3067           zi=mod(zi,boxzsize)
3068           if (zi.lt.0) zi=zi+boxzsize
3069         do iint=1,nscp_gr(i)
3070
3071         do j=iscpstart(i,iint),iscpend(i,iint)
3072           itypj=iabs(itype(j))
3073           if (itypj.eq.ntyp1) cycle
3074 C Uncomment following three lines for SC-p interactions
3075 c         xj=c(1,nres+j)-xi
3076 c         yj=c(2,nres+j)-yi
3077 c         zj=c(3,nres+j)-zi
3078 C Uncomment following three lines for Ca-p interactions
3079           xj=c(1,j)
3080           yj=c(2,j)
3081           zj=c(3,j)
3082 C returning the jth atom to box
3083           xj=mod(xj,boxxsize)
3084           if (xj.lt.0) xj=xj+boxxsize
3085           yj=mod(yj,boxysize)
3086           if (yj.lt.0) yj=yj+boxysize
3087           zj=mod(zj,boxzsize)
3088           if (zj.lt.0) zj=zj+boxzsize
3089       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3090       xj_safe=xj
3091       yj_safe=yj
3092       zj_safe=zj
3093       subchap=0
3094 C Finding the closest jth atom
3095       do xshift=-1,1
3096       do yshift=-1,1
3097       do zshift=-1,1
3098           xj=xj_safe+xshift*boxxsize
3099           yj=yj_safe+yshift*boxysize
3100           zj=zj_safe+zshift*boxzsize
3101           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3102           if(dist_temp.lt.dist_init) then
3103             dist_init=dist_temp
3104             xj_temp=xj
3105             yj_temp=yj
3106             zj_temp=zj
3107             subchap=1
3108           endif
3109        enddo
3110        enddo
3111        enddo
3112        if (subchap.eq.1) then
3113           xj=xj_temp-xi
3114           yj=yj_temp-yi
3115           zj=zj_temp-zi
3116        else
3117           xj=xj_safe-xi
3118           yj=yj_safe-yi
3119           zj=zj_safe-zi
3120        endif
3121           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3122 C sss is scaling function for smoothing the cutoff gradient otherwise
3123 C the gradient would not be continuouse
3124           sss=sscale(1.0d0/(dsqrt(rrij)))
3125           if (sss.le.0.0d0) cycle
3126           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3127           fac=rrij**expon2
3128           e1=fac*fac*aad(itypj,iteli)
3129           e2=fac*bad(itypj,iteli)
3130           if (iabs(j-i) .le. 2) then
3131             e1=scal14*e1
3132             e2=scal14*e2
3133             evdw2_14=evdw2_14+(e1+e2)*sss
3134           endif
3135           evdwij=e1+e2
3136 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3137 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3138 c     &       bad(itypj,iteli)
3139           evdw2=evdw2+evdwij*sss
3140           if (calc_grad) then
3141 C
3142 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3143 C
3144           fac=-(evdwij+e1)*rrij*sss
3145           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3146           ggg(1)=xj*fac
3147           ggg(2)=yj*fac
3148           ggg(3)=zj*fac
3149           if (j.lt.i) then
3150 cd          write (iout,*) 'j<i'
3151 C Uncomment following three lines for SC-p interactions
3152 c           do k=1,3
3153 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3154 c           enddo
3155           else
3156 cd          write (iout,*) 'j>i'
3157             do k=1,3
3158               ggg(k)=-ggg(k)
3159 C Uncomment following line for SC-p interactions
3160 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3161             enddo
3162           endif
3163           do k=1,3
3164             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3165           enddo
3166           kstart=min0(i+1,j)
3167           kend=max0(i-1,j-1)
3168 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3169 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3170           do k=kstart,kend
3171             do l=1,3
3172               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3173             enddo
3174           enddo
3175           endif
3176         enddo
3177         enddo ! iint
3178  1225   continue
3179       enddo ! i
3180       do i=1,nct
3181         do j=1,3
3182           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3183           gradx_scp(j,i)=expon*gradx_scp(j,i)
3184         enddo
3185       enddo
3186 C******************************************************************************
3187 C
3188 C                              N O T E !!!
3189 C
3190 C To save time the factor EXPON has been extracted from ALL components
3191 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3192 C use!
3193 C
3194 C******************************************************************************
3195       return
3196       end
3197 C--------------------------------------------------------------------------
3198       subroutine edis(ehpb)
3199 C
3200 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3201 C
3202       implicit real*8 (a-h,o-z)
3203       include 'DIMENSIONS'
3204       include 'DIMENSIONS.ZSCOPT'
3205       include 'DIMENSIONS.FREE'
3206       include 'COMMON.SBRIDGE'
3207       include 'COMMON.CHAIN'
3208       include 'COMMON.DERIV'
3209       include 'COMMON.VAR'
3210       include 'COMMON.INTERACT'
3211       include 'COMMON.CONTROL'
3212       include 'COMMON.IOUNITS'
3213       dimension ggg(3)
3214       ehpb=0.0D0
3215 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3216 cd    print *,'link_start=',link_start,' link_end=',link_end
3217 C      write(iout,*) link_end, "link_end"
3218       if (link_end.eq.0) return
3219       do i=link_start,link_end
3220 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3221 C CA-CA distance used in regularization of structure.
3222         ii=ihpb(i)
3223         jj=jhpb(i)
3224 C iii and jjj point to the residues for which the distance is assigned.
3225         if (ii.gt.nres) then
3226           iii=ii-nres
3227           jjj=jj-nres
3228         else
3229           iii=ii
3230           jjj=jj
3231         endif
3232 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3233 C    distance and angle dependent SS bond potential.
3234 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3235 C     & iabs(itype(jjj)).eq.1) then
3236 C       write(iout,*) constr_dist,"const"
3237        if (.not.dyn_ss .and. i.le.nss) then
3238          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3239      & iabs(itype(jjj)).eq.1) then
3240           call ssbond_ene(iii,jjj,eij)
3241           ehpb=ehpb+2*eij
3242            endif !ii.gt.neres
3243         else if (ii.gt.nres .and. jj.gt.nres) then
3244 c Restraints from contact prediction
3245           dd=dist(ii,jj)
3246           if (constr_dist.eq.11) then
3247 C            ehpb=ehpb+fordepth(i)**4.0d0
3248 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3249             ehpb=ehpb+fordepth(i)**4.0d0
3250      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3251             fac=fordepth(i)**4.0d0
3252      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3253 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3254 C     &    ehpb,fordepth(i),dd
3255 C            write(iout,*) ehpb,"atu?"
3256 C            ehpb,"tu?"
3257 C            fac=fordepth(i)**4.0d0
3258 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3259            else
3260           if (dhpb1(i).gt.0.0d0) then
3261             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3262             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3263 c            write (iout,*) "beta nmr",
3264 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3265           else
3266             dd=dist(ii,jj)
3267             rdis=dd-dhpb(i)
3268 C Get the force constant corresponding to this distance.
3269             waga=forcon(i)
3270 C Calculate the contribution to energy.
3271             ehpb=ehpb+waga*rdis*rdis
3272 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
3273 C
3274 C Evaluate gradient.
3275 C
3276             fac=waga*rdis/dd
3277           endif !end dhpb1(i).gt.0
3278           endif !end const_dist=11
3279           do j=1,3
3280             ggg(j)=fac*(c(j,jj)-c(j,ii))
3281           enddo
3282           do j=1,3
3283             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3284             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3285           enddo
3286           do k=1,3
3287             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
3288             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
3289           enddo
3290         else !ii.gt.nres
3291 C          write(iout,*) "before"
3292           dd=dist(ii,jj)
3293 C          write(iout,*) "after",dd
3294           if (constr_dist.eq.11) then
3295             ehpb=ehpb+fordepth(i)**4.0d0
3296      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3297             fac=fordepth(i)**4.0d0
3298      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3299 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3300 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3301 C            print *,ehpb,"tu?"
3302 C            write(iout,*) ehpb,"btu?",
3303 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3304 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3305 C     &    ehpb,fordepth(i),dd
3306            else
3307           if (dhpb1(i).gt.0.0d0) then
3308             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3309             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3310 c            write (iout,*) "alph nmr",
3311 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3312           else
3313             rdis=dd-dhpb(i)
3314 C Get the force constant corresponding to this distance.
3315             waga=forcon(i)
3316 C Calculate the contribution to energy.
3317             ehpb=ehpb+waga*rdis*rdis
3318 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3319 C
3320 C Evaluate gradient.
3321 C
3322             fac=waga*rdis/dd
3323           endif
3324           endif
3325
3326         do j=1,3
3327           ggg(j)=fac*(c(j,jj)-c(j,ii))
3328         enddo
3329 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3330 C If this is a SC-SC distance, we need to calculate the contributions to the
3331 C Cartesian gradient in the SC vectors (ghpbx).
3332         if (iii.lt.ii) then
3333           do j=1,3
3334             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3335             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3336           enddo
3337         endif
3338         do j=iii,jjj-1
3339           do k=1,3
3340             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3341           enddo
3342         enddo
3343         endif
3344       enddo
3345       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3346       return
3347       end
3348 C--------------------------------------------------------------------------
3349       subroutine ssbond_ene(i,j,eij)
3350 C
3351 C Calculate the distance and angle dependent SS-bond potential energy
3352 C using a free-energy function derived based on RHF/6-31G** ab initio
3353 C calculations of diethyl disulfide.
3354 C
3355 C A. Liwo and U. Kozlowska, 11/24/03
3356 C
3357       implicit real*8 (a-h,o-z)
3358       include 'DIMENSIONS'
3359       include 'DIMENSIONS.ZSCOPT'
3360       include 'COMMON.SBRIDGE'
3361       include 'COMMON.CHAIN'
3362       include 'COMMON.DERIV'
3363       include 'COMMON.LOCAL'
3364       include 'COMMON.INTERACT'
3365       include 'COMMON.VAR'
3366       include 'COMMON.IOUNITS'
3367       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3368       itypi=iabs(itype(i))
3369       xi=c(1,nres+i)
3370       yi=c(2,nres+i)
3371       zi=c(3,nres+i)
3372       dxi=dc_norm(1,nres+i)
3373       dyi=dc_norm(2,nres+i)
3374       dzi=dc_norm(3,nres+i)
3375       dsci_inv=dsc_inv(itypi)
3376       itypj=iabs(itype(j))
3377       dscj_inv=dsc_inv(itypj)
3378       xj=c(1,nres+j)-xi
3379       yj=c(2,nres+j)-yi
3380       zj=c(3,nres+j)-zi
3381       dxj=dc_norm(1,nres+j)
3382       dyj=dc_norm(2,nres+j)
3383       dzj=dc_norm(3,nres+j)
3384       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3385       rij=dsqrt(rrij)
3386       erij(1)=xj*rij
3387       erij(2)=yj*rij
3388       erij(3)=zj*rij
3389       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3390       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3391       om12=dxi*dxj+dyi*dyj+dzi*dzj
3392       do k=1,3
3393         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3394         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3395       enddo
3396       rij=1.0d0/rij
3397       deltad=rij-d0cm
3398       deltat1=1.0d0-om1
3399       deltat2=1.0d0+om2
3400       deltat12=om2-om1+2.0d0
3401       cosphi=om12-om1*om2
3402       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3403      &  +akct*deltad*deltat12
3404      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3405 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3406 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3407 c     &  " deltat12",deltat12," eij",eij
3408       ed=2*akcm*deltad+akct*deltat12
3409       pom1=akct*deltad
3410       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3411       eom1=-2*akth*deltat1-pom1-om2*pom2
3412       eom2= 2*akth*deltat2+pom1-om1*pom2
3413       eom12=pom2
3414       do k=1,3
3415         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3416       enddo
3417       do k=1,3
3418         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3419      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3420         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3421      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3422       enddo
3423 C
3424 C Calculate the components of the gradient in DC and X
3425 C
3426       do k=i,j-1
3427         do l=1,3
3428           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3429         enddo
3430       enddo
3431       return
3432       end
3433 C--------------------------------------------------------------------------
3434 c MODELLER restraint function
3435       subroutine e_modeller(ehomology_constr)
3436       implicit real*8 (a-h,o-z)
3437       include 'DIMENSIONS'
3438       include 'DIMENSIONS.ZSCOPT'
3439       include 'DIMENSIONS.FREE'
3440       integer nnn, i, j, k, ki, irec, l
3441       integer katy, odleglosci, test7
3442       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3443       real*8 distance(max_template),distancek(max_template),
3444      &    min_odl,godl(max_template),dih_diff(max_template)
3445
3446 c
3447 c     FP - 30/10/2014 Temporary specifications for homology restraints
3448 c
3449       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3450      &                 sgtheta
3451       double precision, dimension (maxres) :: guscdiff,usc_diff
3452       double precision, dimension (max_template) ::
3453      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3454      &           theta_diff
3455
3456       include 'COMMON.SBRIDGE'
3457       include 'COMMON.CHAIN'
3458       include 'COMMON.GEO'
3459       include 'COMMON.DERIV'
3460       include 'COMMON.LOCAL'
3461       include 'COMMON.INTERACT'
3462       include 'COMMON.VAR'
3463       include 'COMMON.IOUNITS'
3464       include 'COMMON.CONTROL'
3465       include 'COMMON.HOMRESTR'
3466 c
3467       include 'COMMON.SETUP'
3468       include 'COMMON.NAMES'
3469
3470       do i=1,max_template
3471         distancek(i)=9999999.9
3472       enddo
3473
3474       odleg=0.0d0
3475
3476 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3477 c function)
3478 C AL 5/2/14 - Introduce list of restraints
3479 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3480 #ifdef DEBUG
3481       write(iout,*) "------- dist restrs start -------"
3482 #endif
3483       do ii = link_start_homo,link_end_homo
3484          i = ires_homo(ii)
3485          j = jres_homo(ii)
3486          dij=dist(i,j)
3487 c        write (iout,*) "dij(",i,j,") =",dij
3488          do k=1,constr_homology
3489            if(.not.l_homo(k,ii)) cycle
3490            distance(k)=odl(k,ii)-dij
3491 c          write (iout,*) "distance(",k,") =",distance(k)
3492 c
3493 c          For Gaussian-type Urestr
3494 c
3495            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
3496 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
3497 c          write (iout,*) "distancek(",k,") =",distancek(k)
3498 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
3499 c
3500 c          For Lorentzian-type Urestr
3501 c
3502            if (waga_dist.lt.0.0d0) then
3503               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
3504               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
3505      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
3506            endif
3507          enddo
3508
3509 c         min_odl=minval(distancek)
3510          do kk=1,constr_homology
3511           if(l_homo(kk,ii)) then
3512             min_odl=distancek(kk)
3513             exit
3514           endif
3515          enddo
3516          do kk=1,constr_homology
3517           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
3518      &              min_odl=distancek(kk)
3519          enddo
3520 c        write (iout,* )"min_odl",min_odl
3521 #ifdef DEBUG
3522          write (iout,*) "ij dij",i,j,dij
3523          write (iout,*) "distance",(distance(k),k=1,constr_homology)
3524          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
3525          write (iout,* )"min_odl",min_odl
3526 #endif
3527          odleg2=0.0d0
3528          do k=1,constr_homology
3529 c Nie wiem po co to liczycie jeszcze raz!
3530 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
3531 c     &              (2*(sigma_odl(i,j,k))**2))
3532            if(.not.l_homo(k,ii)) cycle
3533            if (waga_dist.ge.0.0d0) then
3534 c
3535 c          For Gaussian-type Urestr
3536 c
3537             godl(k)=dexp(-distancek(k)+min_odl)
3538             odleg2=odleg2+godl(k)
3539 c
3540 c          For Lorentzian-type Urestr
3541 c
3542            else
3543             odleg2=odleg2+distancek(k)
3544            endif
3545
3546 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
3547 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
3548 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
3549 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
3550
3551          enddo
3552 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3553 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3554 #ifdef DEBUG
3555          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
3556          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
3557 #endif
3558            if (waga_dist.ge.0.0d0) then
3559 c
3560 c          For Gaussian-type Urestr
3561 c
3562               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
3563 c
3564 c          For Lorentzian-type Urestr
3565 c
3566            else
3567               odleg=odleg+odleg2/constr_homology
3568            endif
3569 c
3570 #ifdef GRAD
3571 c        write (iout,*) "odleg",odleg ! sum of -ln-s
3572 c Gradient
3573 c
3574 c          For Gaussian-type Urestr
3575 c
3576          if (waga_dist.ge.0.0d0) sum_godl=odleg2
3577          sum_sgodl=0.0d0
3578          do k=1,constr_homology
3579 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3580 c     &           *waga_dist)+min_odl
3581 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
3582 c
3583          if(.not.l_homo(k,ii)) cycle
3584          if (waga_dist.ge.0.0d0) then
3585 c          For Gaussian-type Urestr
3586 c
3587            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
3588 c
3589 c          For Lorentzian-type Urestr
3590 c
3591          else
3592            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
3593      &           sigma_odlir(k,ii)**2)**2)
3594          endif
3595            sum_sgodl=sum_sgodl+sgodl
3596
3597 c            sgodl2=sgodl2+sgodl
3598 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
3599 c      write(iout,*) "constr_homology=",constr_homology
3600 c      write(iout,*) i, j, k, "TEST K"
3601          enddo
3602          if (waga_dist.ge.0.0d0) then
3603 c
3604 c          For Gaussian-type Urestr
3605 c
3606             grad_odl3=waga_homology(iset)*waga_dist
3607      &                *sum_sgodl/(sum_godl*dij)
3608 c
3609 c          For Lorentzian-type Urestr
3610 c
3611          else
3612 c Original grad expr modified by analogy w Gaussian-type Urestr grad
3613 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
3614             grad_odl3=-waga_homology(iset)*waga_dist*
3615      &                sum_sgodl/(constr_homology*dij)
3616          endif
3617 c
3618 c        grad_odl3=sum_sgodl/(sum_godl*dij)
3619
3620
3621 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
3622 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
3623 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
3624
3625 ccc      write(iout,*) godl, sgodl, grad_odl3
3626
3627 c          grad_odl=grad_odl+grad_odl3
3628
3629          do jik=1,3
3630             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
3631 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
3632 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
3633 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3634             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
3635             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
3636 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
3637 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
3638 c         if (i.eq.25.and.j.eq.27) then
3639 c         write(iout,*) "jik",jik,"i",i,"j",j
3640 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
3641 c         write(iout,*) "grad_odl3",grad_odl3
3642 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
3643 c         write(iout,*) "ggodl",ggodl
3644 c         write(iout,*) "ghpbc(",jik,i,")",
3645 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
3646 c     &                 ghpbc(jik,j)
3647 c         endif
3648          enddo
3649 #endif
3650 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
3651 ccc     & dLOG(odleg2),"-odleg=", -odleg
3652
3653       enddo ! ii-loop for dist
3654 #ifdef DEBUG
3655       write(iout,*) "------- dist restrs end -------"
3656 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
3657 c    &     waga_d.eq.1.0d0) call sum_gradient
3658 #endif
3659 c Pseudo-energy and gradient from dihedral-angle restraints from
3660 c homology templates
3661 c      write (iout,*) "End of distance loop"
3662 c      call flush(iout)
3663       kat=0.0d0
3664 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
3665 #ifdef DEBUG
3666       write(iout,*) "------- dih restrs start -------"
3667       do i=idihconstr_start_homo,idihconstr_end_homo
3668         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
3669       enddo
3670 #endif
3671       do i=idihconstr_start_homo,idihconstr_end_homo
3672         kat2=0.0d0
3673 c        betai=beta(i,i+1,i+2,i+3)
3674         betai = phi(i)
3675 c       write (iout,*) "betai =",betai
3676         do k=1,constr_homology
3677           dih_diff(k)=pinorm(dih(k,i)-betai)
3678 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
3679 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
3680 c     &                                   -(6.28318-dih_diff(i,k))
3681 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
3682 c     &                                   6.28318+dih_diff(i,k)
3683
3684           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
3685 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
3686           gdih(k)=dexp(kat3)
3687           kat2=kat2+gdih(k)
3688 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
3689 c          write(*,*)""
3690         enddo
3691 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
3692 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
3693 #ifdef DEBUG
3694         write (iout,*) "i",i," betai",betai," kat2",kat2
3695         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
3696 #endif
3697         if (kat2.le.1.0d-14) cycle
3698         kat=kat-dLOG(kat2/constr_homology)
3699 c       write (iout,*) "kat",kat ! sum of -ln-s
3700
3701 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
3702 ccc     & dLOG(kat2), "-kat=", -kat
3703
3704 #ifdef GRAD
3705 c ----------------------------------------------------------------------
3706 c Gradient
3707 c ----------------------------------------------------------------------
3708
3709         sum_gdih=kat2
3710         sum_sgdih=0.0d0
3711         do k=1,constr_homology
3712           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
3713 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
3714           sum_sgdih=sum_sgdih+sgdih
3715         enddo
3716 c       grad_dih3=sum_sgdih/sum_gdih
3717         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
3718
3719 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
3720 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
3721 ccc     & gloc(nphi+i-3,icg)
3722         gloc(i,icg)=gloc(i,icg)+grad_dih3
3723 c        if (i.eq.25) then
3724 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
3725 c        endif
3726 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
3727 ccc     & gloc(nphi+i-3,icg)
3728 #endif
3729       enddo ! i-loop for dih
3730 #ifdef DEBUG
3731       write(iout,*) "------- dih restrs end -------"
3732 #endif
3733
3734 c Pseudo-energy and gradient for theta angle restraints from
3735 c homology templates
3736 c FP 01/15 - inserted from econstr_local_test.F, loop structure
3737 c adapted
3738
3739 c
3740 c     For constr_homology reference structures (FP)
3741 c
3742 c     Uconst_back_tot=0.0d0
3743       Eval=0.0d0
3744       Erot=0.0d0
3745 c     Econstr_back legacy
3746 #ifdef GRAD
3747       do i=1,nres
3748 c     do i=ithet_start,ithet_end
3749        dutheta(i)=0.0d0
3750 c     enddo
3751 c     do i=loc_start,loc_end
3752         do j=1,3
3753           duscdiff(j,i)=0.0d0
3754           duscdiffx(j,i)=0.0d0
3755         enddo
3756       enddo
3757 #endif
3758 c
3759 c     do iref=1,nref
3760 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
3761 c     write (iout,*) "waga_theta",waga_theta
3762       if (waga_theta.gt.0.0d0) then
3763 #ifdef DEBUG
3764       write (iout,*) "usampl",usampl
3765       write(iout,*) "------- theta restrs start -------"
3766 c     do i=ithet_start,ithet_end
3767 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
3768 c     enddo
3769 #endif
3770 c     write (iout,*) "maxres",maxres,"nres",nres
3771
3772       do i=ithet_start,ithet_end
3773 c
3774 c     do i=1,nfrag_back
3775 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
3776 c
3777 c Deviation of theta angles wrt constr_homology ref structures
3778 c
3779         utheta_i=0.0d0 ! argument of Gaussian for single k
3780         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3781 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
3782 c       over residues in a fragment
3783 c       write (iout,*) "theta(",i,")=",theta(i)
3784         do k=1,constr_homology
3785 c
3786 c         dtheta_i=theta(j)-thetaref(j,iref)
3787 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
3788           theta_diff(k)=thetatpl(k,i)-theta(i)
3789 c
3790           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
3791 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
3792           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
3793           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
3794 c         Gradient for single Gaussian restraint in subr Econstr_back
3795 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
3796 c
3797         enddo
3798 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
3799 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
3800
3801 c
3802 #ifdef GRAD
3803 c         Gradient for multiple Gaussian restraint
3804         sum_gtheta=gutheta_i
3805         sum_sgtheta=0.0d0
3806         do k=1,constr_homology
3807 c        New generalized expr for multiple Gaussian from Econstr_back
3808          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
3809 c
3810 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
3811           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
3812         enddo
3813 c
3814 c       Final value of gradient using same var as in Econstr_back
3815         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
3816      &               *waga_homology(iset)
3817 c       dutheta(i)=sum_sgtheta/sum_gtheta
3818 c
3819 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
3820 #endif
3821         Eval=Eval-dLOG(gutheta_i/constr_homology)
3822 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
3823 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
3824 c       Uconst_back=Uconst_back+utheta(i)
3825       enddo ! (i-loop for theta)
3826 #ifdef DEBUG
3827       write(iout,*) "------- theta restrs end -------"
3828 #endif
3829       endif
3830 c
3831 c Deviation of local SC geometry
3832 c
3833 c Separation of two i-loops (instructed by AL - 11/3/2014)
3834 c
3835 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
3836 c     write (iout,*) "waga_d",waga_d
3837
3838 #ifdef DEBUG
3839       write(iout,*) "------- SC restrs start -------"
3840       write (iout,*) "Initial duscdiff,duscdiffx"
3841       do i=loc_start,loc_end
3842         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
3843      &                 (duscdiffx(jik,i),jik=1,3)
3844       enddo
3845 #endif
3846       do i=loc_start,loc_end
3847         usc_diff_i=0.0d0 ! argument of Gaussian for single k
3848         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
3849 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
3850 c       write(iout,*) "xxtab, yytab, zztab"
3851 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
3852         do k=1,constr_homology
3853 c
3854           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3855 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
3856           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3857           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3858 c         write(iout,*) "dxx, dyy, dzz"
3859 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3860 c
3861           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
3862 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
3863 c         uscdiffk(k)=usc_diff(i)
3864           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
3865           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
3866 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
3867 c     &      xxref(j),yyref(j),zzref(j)
3868         enddo
3869 c
3870 c       Gradient
3871 c
3872 c       Generalized expression for multiple Gaussian acc to that for a single
3873 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
3874 c
3875 c       Original implementation
3876 c       sum_guscdiff=guscdiff(i)
3877 c
3878 c       sum_sguscdiff=0.0d0
3879 c       do k=1,constr_homology
3880 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
3881 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
3882 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
3883 c       enddo
3884 c
3885 c       Implementation of new expressions for gradient (Jan. 2015)
3886 c
3887 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
3888 #ifdef GRAD
3889         do k=1,constr_homology
3890 c
3891 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
3892 c       before. Now the drivatives should be correct
3893 c
3894           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
3895 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
3896           dyy=-yytpl(k,i)+yytab(i) ! ibid y
3897           dzz=-zztpl(k,i)+zztab(i) ! ibid z
3898 c
3899 c         New implementation
3900 c
3901           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
3902      &                 sigma_d(k,i) ! for the grad wrt r'
3903 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
3904 c
3905 c
3906 c        New implementation
3907          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
3908          do jik=1,3
3909             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
3910      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
3911      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
3912             duscdiff(jik,i)=duscdiff(jik,i)+
3913      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
3914      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
3915             duscdiffx(jik,i)=duscdiffx(jik,i)+
3916      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
3917      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
3918 c
3919 #ifdef DEBUG
3920              write(iout,*) "jik",jik,"i",i
3921              write(iout,*) "dxx, dyy, dzz"
3922              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
3923              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
3924 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
3925 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
3926 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
3927 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
3928 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
3929 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
3930 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
3931 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
3932 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
3933 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
3934 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
3935 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
3936 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
3937 c            endif
3938 #endif
3939          enddo
3940         enddo
3941 #endif
3942 c
3943 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
3944 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
3945 c
3946 c        write (iout,*) i," uscdiff",uscdiff(i)
3947 c
3948 c Put together deviations from local geometry
3949
3950 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
3951 c      &            wfrag_back(3,i,iset)*uscdiff(i)
3952         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
3953 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
3954 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
3955 c       Uconst_back=Uconst_back+usc_diff(i)
3956 c
3957 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
3958 c
3959 c     New implment: multiplied by sum_sguscdiff
3960 c
3961
3962       enddo ! (i-loop for dscdiff)
3963
3964 c      endif
3965
3966 #ifdef DEBUG
3967       write(iout,*) "------- SC restrs end -------"
3968         write (iout,*) "------ After SC loop in e_modeller ------"
3969         do i=loc_start,loc_end
3970          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
3971          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
3972         enddo
3973       if (waga_theta.eq.1.0d0) then
3974       write (iout,*) "in e_modeller after SC restr end: dutheta"
3975       do i=ithet_start,ithet_end
3976         write (iout,*) i,dutheta(i)
3977       enddo
3978       endif
3979       if (waga_d.eq.1.0d0) then
3980       write (iout,*) "e_modeller after SC loop: duscdiff/x"
3981       do i=1,nres
3982         write (iout,*) i,(duscdiff(j,i),j=1,3)
3983         write (iout,*) i,(duscdiffx(j,i),j=1,3)
3984       enddo
3985       endif
3986 #endif
3987
3988 c Total energy from homology restraints
3989 #ifdef DEBUG
3990       write (iout,*) "odleg",odleg," kat",kat
3991       write (iout,*) "odleg",odleg," kat",kat
3992       write (iout,*) "Eval",Eval," Erot",Erot
3993       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
3994       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
3995       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
3996 #endif
3997 c
3998 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
3999 c
4000 c     ehomology_constr=odleg+kat
4001 c
4002 c     For Lorentzian-type Urestr
4003 c
4004
4005       if (waga_dist.ge.0.0d0) then
4006 c
4007 c          For Gaussian-type Urestr
4008 c
4009 c        ehomology_constr=(waga_dist*odleg+waga_angle*kat+
4010 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4011         ehomology_constr=waga_dist*odleg+waga_angle*kat+
4012      &              waga_theta*Eval+waga_d*Erot
4013 c     write (iout,*) "ehomology_constr=",ehomology_constr
4014       else
4015 c
4016 c          For Lorentzian-type Urestr
4017 c
4018 c        ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
4019 c     &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4020         ehomology_constr=-waga_dist*odleg+waga_angle*kat+
4021      &              waga_theta*Eval+waga_d*Erot
4022 c     write (iout,*) "ehomology_constr=",ehomology_constr
4023       endif
4024 #ifdef DEBUG
4025       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
4026      & "Eval",waga_theta,eval,
4027      &   "Erot",waga_d,Erot
4028       write (iout,*) "ehomology_constr",ehomology_constr
4029 #endif
4030       return
4031
4032   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
4033   747 format(a12,i4,i4,i4,f8.3,f8.3)
4034   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
4035   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
4036   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
4037      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
4038       end
4039 c-----------------------------------------------------------------------
4040       subroutine ebond(estr)
4041 c
4042 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4043 c
4044       implicit real*8 (a-h,o-z)
4045       include 'DIMENSIONS'
4046       include 'DIMENSIONS.ZSCOPT'
4047       include 'DIMENSIONS.FREE'
4048       include 'COMMON.LOCAL'
4049       include 'COMMON.GEO'
4050       include 'COMMON.INTERACT'
4051       include 'COMMON.DERIV'
4052       include 'COMMON.VAR'
4053       include 'COMMON.CHAIN'
4054       include 'COMMON.IOUNITS'
4055       include 'COMMON.NAMES'
4056       include 'COMMON.FFIELD'
4057       include 'COMMON.CONTROL'
4058       logical energy_dec /.false./
4059       double precision u(3),ud(3)
4060       estr=0.0d0
4061 C      write (iout,*) "distchainmax",distchainmax
4062       estr1=0.0d0
4063 c      write (iout,*) "distchainmax",distchainmax
4064       do i=nnt+1,nct
4065         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4066 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4067 C          do j=1,3
4068 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4069 C     &      *dc(j,i-1)/vbld(i)
4070 C          enddo
4071 C          if (energy_dec) write(iout,*)
4072 C     &       "estr1",i,vbld(i),distchainmax,
4073 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4074 C        else
4075          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4076         diff = vbld(i)-vbldpDUM
4077 C         write(iout,*) i,diff
4078          else
4079           diff = vbld(i)-vbldp0
4080 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4081          endif
4082           estr=estr+diff*diff
4083           do j=1,3
4084             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4085           enddo
4086 C        endif
4087 C        write (iout,'(a7,i5,4f7.3)')
4088 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4089       enddo
4090       estr=0.5d0*AKP*estr+estr1
4091 c
4092 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4093 c
4094       do i=nnt,nct
4095         iti=iabs(itype(i))
4096         if (iti.ne.10 .and. iti.ne.ntyp1) then
4097           nbi=nbondterm(iti)
4098           if (nbi.eq.1) then
4099             diff=vbld(i+nres)-vbldsc0(1,iti)
4100 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4101 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4102             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4103             do j=1,3
4104               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4105             enddo
4106           else
4107             do j=1,nbi
4108               diff=vbld(i+nres)-vbldsc0(j,iti)
4109               ud(j)=aksc(j,iti)*diff
4110               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4111             enddo
4112             uprod=u(1)
4113             do j=2,nbi
4114               uprod=uprod*u(j)
4115             enddo
4116             usum=0.0d0
4117             usumsqder=0.0d0
4118             do j=1,nbi
4119               uprod1=1.0d0
4120               uprod2=1.0d0
4121               do k=1,nbi
4122                 if (k.ne.j) then
4123                   uprod1=uprod1*u(k)
4124                   uprod2=uprod2*u(k)*u(k)
4125                 endif
4126               enddo
4127               usum=usum+uprod1
4128               usumsqder=usumsqder+ud(j)*uprod2
4129             enddo
4130 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4131 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4132             estr=estr+uprod/usum
4133             do j=1,3
4134              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4135             enddo
4136           endif
4137         endif
4138       enddo
4139       return
4140       end
4141 #ifdef CRYST_THETA
4142 C--------------------------------------------------------------------------
4143       subroutine ebend(etheta)
4144 C
4145 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4146 C angles gamma and its derivatives in consecutive thetas and gammas.
4147 C
4148       implicit real*8 (a-h,o-z)
4149       include 'DIMENSIONS'
4150       include 'DIMENSIONS.ZSCOPT'
4151       include 'COMMON.LOCAL'
4152       include 'COMMON.GEO'
4153       include 'COMMON.INTERACT'
4154       include 'COMMON.DERIV'
4155       include 'COMMON.VAR'
4156       include 'COMMON.CHAIN'
4157       include 'COMMON.IOUNITS'
4158       include 'COMMON.NAMES'
4159       include 'COMMON.FFIELD'
4160       common /calcthet/ term1,term2,termm,diffak,ratak,
4161      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4162      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4163       double precision y(2),z(2)
4164       delta=0.02d0*pi
4165       time11=dexp(-2*time)
4166       time12=1.0d0
4167       etheta=0.0D0
4168 c      write (iout,*) "nres",nres
4169 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4170 c      write (iout,*) ithet_start,ithet_end
4171       do i=ithet_start,ithet_end
4172 C        if (itype(i-1).eq.ntyp1) cycle
4173 c        if (i.le.2) cycle
4174         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4175      &  .or.itype(i).eq.ntyp1) cycle
4176 C Zero the energy function and its derivative at 0 or pi.
4177         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4178         it=itype(i-1)
4179         ichir1=isign(1,itype(i-2))
4180         ichir2=isign(1,itype(i))
4181          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4182          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4183          if (itype(i-1).eq.10) then
4184           itype1=isign(10,itype(i-2))
4185           ichir11=isign(1,itype(i-2))
4186           ichir12=isign(1,itype(i-2))
4187           itype2=isign(10,itype(i))
4188           ichir21=isign(1,itype(i))
4189           ichir22=isign(1,itype(i))
4190          endif
4191          if (i.eq.3) then
4192           y(1)=0.0D0
4193           y(2)=0.0D0
4194           else
4195
4196         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4197 #ifdef OSF
4198           phii=phi(i)
4199 c          icrc=0
4200 c          call proc_proc(phii,icrc)
4201           if (icrc.eq.1) phii=150.0
4202 #else
4203           phii=phi(i)
4204 #endif
4205           y(1)=dcos(phii)
4206           y(2)=dsin(phii)
4207         else
4208           y(1)=0.0D0
4209           y(2)=0.0D0
4210         endif
4211         endif
4212         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4213 #ifdef OSF
4214           phii1=phi(i+1)
4215 c          icrc=0
4216 c          call proc_proc(phii1,icrc)
4217           if (icrc.eq.1) phii1=150.0
4218           phii1=pinorm(phii1)
4219           z(1)=cos(phii1)
4220 #else
4221           phii1=phi(i+1)
4222           z(1)=dcos(phii1)
4223 #endif
4224           z(2)=dsin(phii1)
4225         else
4226           z(1)=0.0D0
4227           z(2)=0.0D0
4228         endif
4229 C Calculate the "mean" value of theta from the part of the distribution
4230 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4231 C In following comments this theta will be referred to as t_c.
4232         thet_pred_mean=0.0d0
4233         do k=1,2
4234             athetk=athet(k,it,ichir1,ichir2)
4235             bthetk=bthet(k,it,ichir1,ichir2)
4236           if (it.eq.10) then
4237              athetk=athet(k,itype1,ichir11,ichir12)
4238              bthetk=bthet(k,itype2,ichir21,ichir22)
4239           endif
4240           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4241         enddo
4242 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4243         dthett=thet_pred_mean*ssd
4244         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4245 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4246 C Derivatives of the "mean" values in gamma1 and gamma2.
4247         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4248      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4249          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4250      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4251          if (it.eq.10) then
4252       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4253      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4254         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4255      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4256          endif
4257         if (theta(i).gt.pi-delta) then
4258           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4259      &         E_tc0)
4260           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4261           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4262           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4263      &        E_theta)
4264           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4265      &        E_tc)
4266         else if (theta(i).lt.delta) then
4267           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4268           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4269           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4270      &        E_theta)
4271           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4272           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4273      &        E_tc)
4274         else
4275           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4276      &        E_theta,E_tc)
4277         endif
4278         etheta=etheta+ethetai
4279 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4280 c     &      'ebend',i,ethetai,theta(i),itype(i)
4281 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4282 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4283         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4284         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4285         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4286 c 1215   continue
4287       enddo
4288       ethetacnstr=0.0d0
4289 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4290       do i=1,ntheta_constr
4291         itheta=itheta_constr(i)
4292         thetiii=theta(itheta)
4293         difi=pinorm(thetiii-theta_constr0(i))
4294         if (difi.gt.theta_drange(i)) then
4295           difi=difi-theta_drange(i)
4296           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4297           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4298      &    +for_thet_constr(i)*difi**3
4299         else if (difi.lt.-drange(i)) then
4300           difi=difi+drange(i)
4301           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4302           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4303      &    +for_thet_constr(i)*difi**3
4304         else
4305           difi=0.0
4306         endif
4307 C       if (energy_dec) then
4308 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4309 C     &    i,itheta,rad2deg*thetiii,
4310 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4311 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4312 C     &    gloc(itheta+nphi-2,icg)
4313 C        endif
4314       enddo
4315 C Ufff.... We've done all this!!!
4316       return
4317       end
4318 C---------------------------------------------------------------------------
4319       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4320      &     E_tc)
4321       implicit real*8 (a-h,o-z)
4322       include 'DIMENSIONS'
4323       include 'COMMON.LOCAL'
4324       include 'COMMON.IOUNITS'
4325       common /calcthet/ term1,term2,termm,diffak,ratak,
4326      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4327      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4328 C Calculate the contributions to both Gaussian lobes.
4329 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4330 C The "polynomial part" of the "standard deviation" of this part of
4331 C the distribution.
4332         sig=polthet(3,it)
4333         do j=2,0,-1
4334           sig=sig*thet_pred_mean+polthet(j,it)
4335         enddo
4336 C Derivative of the "interior part" of the "standard deviation of the"
4337 C gamma-dependent Gaussian lobe in t_c.
4338         sigtc=3*polthet(3,it)
4339         do j=2,1,-1
4340           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4341         enddo
4342         sigtc=sig*sigtc
4343 C Set the parameters of both Gaussian lobes of the distribution.
4344 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4345         fac=sig*sig+sigc0(it)
4346         sigcsq=fac+fac
4347         sigc=1.0D0/sigcsq
4348 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4349         sigsqtc=-4.0D0*sigcsq*sigtc
4350 c       print *,i,sig,sigtc,sigsqtc
4351 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4352         sigtc=-sigtc/(fac*fac)
4353 C Following variable is sigma(t_c)**(-2)
4354         sigcsq=sigcsq*sigcsq
4355         sig0i=sig0(it)
4356         sig0inv=1.0D0/sig0i**2
4357         delthec=thetai-thet_pred_mean
4358         delthe0=thetai-theta0i
4359         term1=-0.5D0*sigcsq*delthec*delthec
4360         term2=-0.5D0*sig0inv*delthe0*delthe0
4361 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4362 C NaNs in taking the logarithm. We extract the largest exponent which is added
4363 C to the energy (this being the log of the distribution) at the end of energy
4364 C term evaluation for this virtual-bond angle.
4365         if (term1.gt.term2) then
4366           termm=term1
4367           term2=dexp(term2-termm)
4368           term1=1.0d0
4369         else
4370           termm=term2
4371           term1=dexp(term1-termm)
4372           term2=1.0d0
4373         endif
4374 C The ratio between the gamma-independent and gamma-dependent lobes of
4375 C the distribution is a Gaussian function of thet_pred_mean too.
4376         diffak=gthet(2,it)-thet_pred_mean
4377         ratak=diffak/gthet(3,it)**2
4378         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4379 C Let's differentiate it in thet_pred_mean NOW.
4380         aktc=ak*ratak
4381 C Now put together the distribution terms to make complete distribution.
4382         termexp=term1+ak*term2
4383         termpre=sigc+ak*sig0i
4384 C Contribution of the bending energy from this theta is just the -log of
4385 C the sum of the contributions from the two lobes and the pre-exponential
4386 C factor. Simple enough, isn't it?
4387         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4388 C NOW the derivatives!!!
4389 C 6/6/97 Take into account the deformation.
4390         E_theta=(delthec*sigcsq*term1
4391      &       +ak*delthe0*sig0inv*term2)/termexp
4392         E_tc=((sigtc+aktc*sig0i)/termpre
4393      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4394      &       aktc*term2)/termexp)
4395       return
4396       end
4397 c-----------------------------------------------------------------------------
4398       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4399       implicit real*8 (a-h,o-z)
4400       include 'DIMENSIONS'
4401       include 'COMMON.LOCAL'
4402       include 'COMMON.IOUNITS'
4403       common /calcthet/ term1,term2,termm,diffak,ratak,
4404      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4405      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4406       delthec=thetai-thet_pred_mean
4407       delthe0=thetai-theta0i
4408 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4409       t3 = thetai-thet_pred_mean
4410       t6 = t3**2
4411       t9 = term1
4412       t12 = t3*sigcsq
4413       t14 = t12+t6*sigsqtc
4414       t16 = 1.0d0
4415       t21 = thetai-theta0i
4416       t23 = t21**2
4417       t26 = term2
4418       t27 = t21*t26
4419       t32 = termexp
4420       t40 = t32**2
4421       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4422      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4423      & *(-t12*t9-ak*sig0inv*t27)
4424       return
4425       end
4426 #else
4427 C--------------------------------------------------------------------------
4428       subroutine ebend(etheta)
4429 C
4430 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4431 C angles gamma and its derivatives in consecutive thetas and gammas.
4432 C ab initio-derived potentials from
4433 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4434 C
4435       implicit real*8 (a-h,o-z)
4436       include 'DIMENSIONS'
4437       include 'DIMENSIONS.ZSCOPT'
4438       include 'DIMENSIONS.FREE'
4439       include 'COMMON.LOCAL'
4440       include 'COMMON.GEO'
4441       include 'COMMON.INTERACT'
4442       include 'COMMON.DERIV'
4443       include 'COMMON.VAR'
4444       include 'COMMON.CHAIN'
4445       include 'COMMON.IOUNITS'
4446       include 'COMMON.NAMES'
4447       include 'COMMON.FFIELD'
4448       include 'COMMON.CONTROL'
4449       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4450      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4451      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4452      & sinph1ph2(maxdouble,maxdouble)
4453       logical lprn /.false./, lprn1 /.false./
4454       etheta=0.0D0
4455 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4456       do i=ithet_start,ithet_end
4457 c        if (i.eq.2) cycle
4458 c        print *,i,itype(i-1),itype(i),itype(i-2)
4459         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
4460      &  .or.(itype(i).eq.ntyp1)) cycle
4461 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
4462
4463         if (iabs(itype(i+1)).eq.20) iblock=2
4464         if (iabs(itype(i+1)).ne.20) iblock=1
4465         dethetai=0.0d0
4466         dephii=0.0d0
4467         dephii1=0.0d0
4468         theti2=0.5d0*theta(i)
4469         ityp2=ithetyp((itype(i-1)))
4470         do k=1,nntheterm
4471           coskt(k)=dcos(k*theti2)
4472           sinkt(k)=dsin(k*theti2)
4473         enddo
4474         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4475 #ifdef OSF
4476           phii=phi(i)
4477           if (phii.ne.phii) phii=150.0
4478 #else
4479           phii=phi(i)
4480 #endif
4481           ityp1=ithetyp((itype(i-2)))
4482           do k=1,nsingle
4483             cosph1(k)=dcos(k*phii)
4484             sinph1(k)=dsin(k*phii)
4485           enddo
4486         else
4487           phii=0.0d0
4488           ityp1=ithetyp(itype(i-2))
4489           do k=1,nsingle
4490             cosph1(k)=0.0d0
4491             sinph1(k)=0.0d0
4492           enddo
4493         endif
4494         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4495 #ifdef OSF
4496           phii1=phi(i+1)
4497           if (phii1.ne.phii1) phii1=150.0
4498           phii1=pinorm(phii1)
4499 #else
4500           phii1=phi(i+1)
4501 #endif
4502           ityp3=ithetyp((itype(i)))
4503           do k=1,nsingle
4504             cosph2(k)=dcos(k*phii1)
4505             sinph2(k)=dsin(k*phii1)
4506           enddo
4507         else
4508           phii1=0.0d0
4509           ityp3=ithetyp(itype(i))
4510           do k=1,nsingle
4511             cosph2(k)=0.0d0
4512             sinph2(k)=0.0d0
4513           enddo
4514         endif
4515 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4516 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4517 c        call flush(iout)
4518         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4519         do k=1,ndouble
4520           do l=1,k-1
4521             ccl=cosph1(l)*cosph2(k-l)
4522             ssl=sinph1(l)*sinph2(k-l)
4523             scl=sinph1(l)*cosph2(k-l)
4524             csl=cosph1(l)*sinph2(k-l)
4525             cosph1ph2(l,k)=ccl-ssl
4526             cosph1ph2(k,l)=ccl+ssl
4527             sinph1ph2(l,k)=scl+csl
4528             sinph1ph2(k,l)=scl-csl
4529           enddo
4530         enddo
4531         if (lprn) then
4532         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4533      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4534         write (iout,*) "coskt and sinkt"
4535         do k=1,nntheterm
4536           write (iout,*) k,coskt(k),sinkt(k)
4537         enddo
4538         endif
4539         do k=1,ntheterm
4540           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4541           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4542      &      *coskt(k)
4543           if (lprn)
4544      &    write (iout,*) "k",k,"
4545      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4546      &     " ethetai",ethetai
4547         enddo
4548         if (lprn) then
4549         write (iout,*) "cosph and sinph"
4550         do k=1,nsingle
4551           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4552         enddo
4553         write (iout,*) "cosph1ph2 and sinph2ph2"
4554         do k=2,ndouble
4555           do l=1,k-1
4556             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4557      &         sinph1ph2(l,k),sinph1ph2(k,l)
4558           enddo
4559         enddo
4560         write(iout,*) "ethetai",ethetai
4561         endif
4562         do m=1,ntheterm2
4563           do k=1,nsingle
4564             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4565      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4566      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4567      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4568             ethetai=ethetai+sinkt(m)*aux
4569             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4570             dephii=dephii+k*sinkt(m)*(
4571      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4572      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4573             dephii1=dephii1+k*sinkt(m)*(
4574      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4575      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4576             if (lprn)
4577      &      write (iout,*) "m",m," k",k," bbthet",
4578      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4579      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4580      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4581      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4582           enddo
4583         enddo
4584         if (lprn)
4585      &  write(iout,*) "ethetai",ethetai
4586         do m=1,ntheterm3
4587           do k=2,ndouble
4588             do l=1,k-1
4589               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4590      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4591      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4592      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4593               ethetai=ethetai+sinkt(m)*aux
4594               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4595               dephii=dephii+l*sinkt(m)*(
4596      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4597      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4598      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4599      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4600               dephii1=dephii1+(k-l)*sinkt(m)*(
4601      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4602      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4603      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4604      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4605               if (lprn) then
4606               write (iout,*) "m",m," k",k," l",l," ffthet",
4607      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4608      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4609      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4610      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4611      &            " ethetai",ethetai
4612               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4613      &            cosph1ph2(k,l)*sinkt(m),
4614      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4615               endif
4616             enddo
4617           enddo
4618         enddo
4619 10      continue
4620         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4621      &   i,theta(i)*rad2deg,phii*rad2deg,
4622      &   phii1*rad2deg,ethetai
4623         etheta=etheta+ethetai
4624         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4625         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4626 c        gloc(nphi+i-2,icg)=wang*dethetai
4627         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4628       enddo
4629 C now constrains
4630       ethetacnstr=0.0d0
4631 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4632       do i=1,ntheta_constr
4633         itheta=itheta_constr(i)
4634         thetiii=theta(itheta)
4635         difi=pinorm(thetiii-theta_constr0(i))
4636         if (difi.gt.theta_drange(i)) then
4637           difi=difi-theta_drange(i)
4638           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4639           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4640      &    +for_thet_constr(i)*difi**3
4641         else if (difi.lt.-drange(i)) then
4642           difi=difi+drange(i)
4643           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4644           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4645      &    +for_thet_constr(i)*difi**3
4646         else
4647           difi=0.0
4648         endif
4649 C       if (energy_dec) then
4650 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4651 C     &    i,itheta,rad2deg*thetiii,
4652 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4653 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4654 C     &    gloc(itheta+nphi-2,icg)
4655 C        endif
4656       enddo
4657       return
4658       end
4659
4660 #endif
4661 #ifdef CRYST_SC
4662 c-----------------------------------------------------------------------------
4663       subroutine esc(escloc)
4664 C Calculate the local energy of a side chain and its derivatives in the
4665 C corresponding virtual-bond valence angles THETA and the spherical angles
4666 C ALPHA and OMEGA.
4667       implicit real*8 (a-h,o-z)
4668       include 'DIMENSIONS'
4669       include 'DIMENSIONS.ZSCOPT'
4670       include 'COMMON.GEO'
4671       include 'COMMON.LOCAL'
4672       include 'COMMON.VAR'
4673       include 'COMMON.INTERACT'
4674       include 'COMMON.DERIV'
4675       include 'COMMON.CHAIN'
4676       include 'COMMON.IOUNITS'
4677       include 'COMMON.NAMES'
4678       include 'COMMON.FFIELD'
4679       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4680      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4681       common /sccalc/ time11,time12,time112,theti,it,nlobit
4682       delta=0.02d0*pi
4683       escloc=0.0D0
4684 C      write (iout,*) 'ESC'
4685       do i=loc_start,loc_end
4686         it=itype(i)
4687         if (it.eq.ntyp1) cycle
4688         if (it.eq.10) goto 1
4689         nlobit=nlob(iabs(it))
4690 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4691 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4692         theti=theta(i+1)-pipol
4693         x(1)=dtan(theti)
4694         x(2)=alph(i)
4695         x(3)=omeg(i)
4696 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4697
4698         if (x(2).gt.pi-delta) then
4699           xtemp(1)=x(1)
4700           xtemp(2)=pi-delta
4701           xtemp(3)=x(3)
4702           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4703           xtemp(2)=pi
4704           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4705           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4706      &        escloci,dersc(2))
4707           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4708      &        ddersc0(1),dersc(1))
4709           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4710      &        ddersc0(3),dersc(3))
4711           xtemp(2)=pi-delta
4712           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4713           xtemp(2)=pi
4714           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4715           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4716      &            dersc0(2),esclocbi,dersc02)
4717           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4718      &            dersc12,dersc01)
4719           call splinthet(x(2),0.5d0*delta,ss,ssd)
4720           dersc0(1)=dersc01
4721           dersc0(2)=dersc02
4722           dersc0(3)=0.0d0
4723           do k=1,3
4724             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4725           enddo
4726           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4727           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4728      &             esclocbi,ss,ssd
4729           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4730 c         escloci=esclocbi
4731 c         write (iout,*) escloci
4732         else if (x(2).lt.delta) then
4733           xtemp(1)=x(1)
4734           xtemp(2)=delta
4735           xtemp(3)=x(3)
4736           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4737           xtemp(2)=0.0d0
4738           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4739           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4740      &        escloci,dersc(2))
4741           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4742      &        ddersc0(1),dersc(1))
4743           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4744      &        ddersc0(3),dersc(3))
4745           xtemp(2)=delta
4746           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4747           xtemp(2)=0.0d0
4748           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4749           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4750      &            dersc0(2),esclocbi,dersc02)
4751           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4752      &            dersc12,dersc01)
4753           dersc0(1)=dersc01
4754           dersc0(2)=dersc02
4755           dersc0(3)=0.0d0
4756           call splinthet(x(2),0.5d0*delta,ss,ssd)
4757           do k=1,3
4758             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4759           enddo
4760           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4761 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4762 c     &             esclocbi,ss,ssd
4763           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4764 C         write (iout,*) 'i=',i, escloci
4765         else
4766           call enesc(x,escloci,dersc,ddummy,.false.)
4767         endif
4768
4769         escloc=escloc+escloci
4770 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4771             write (iout,'(a6,i5,0pf7.3)')
4772      &     'escloc',i,escloci
4773
4774         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4775      &   wscloc*dersc(1)
4776         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4777         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4778     1   continue
4779       enddo
4780       return
4781       end
4782 C---------------------------------------------------------------------------
4783       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4784       implicit real*8 (a-h,o-z)
4785       include 'DIMENSIONS'
4786       include 'COMMON.GEO'
4787       include 'COMMON.LOCAL'
4788       include 'COMMON.IOUNITS'
4789       common /sccalc/ time11,time12,time112,theti,it,nlobit
4790       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4791       double precision contr(maxlob,-1:1)
4792       logical mixed
4793 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4794         escloc_i=0.0D0
4795         do j=1,3
4796           dersc(j)=0.0D0
4797           if (mixed) ddersc(j)=0.0d0
4798         enddo
4799         x3=x(3)
4800
4801 C Because of periodicity of the dependence of the SC energy in omega we have
4802 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4803 C To avoid underflows, first compute & store the exponents.
4804
4805         do iii=-1,1
4806
4807           x(3)=x3+iii*dwapi
4808
4809           do j=1,nlobit
4810             do k=1,3
4811               z(k)=x(k)-censc(k,j,it)
4812             enddo
4813             do k=1,3
4814               Axk=0.0D0
4815               do l=1,3
4816                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4817               enddo
4818               Ax(k,j,iii)=Axk
4819             enddo
4820             expfac=0.0D0
4821             do k=1,3
4822               expfac=expfac+Ax(k,j,iii)*z(k)
4823             enddo
4824             contr(j,iii)=expfac
4825           enddo ! j
4826
4827         enddo ! iii
4828
4829         x(3)=x3
4830 C As in the case of ebend, we want to avoid underflows in exponentiation and
4831 C subsequent NaNs and INFs in energy calculation.
4832 C Find the largest exponent
4833         emin=contr(1,-1)
4834         do iii=-1,1
4835           do j=1,nlobit
4836             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4837           enddo
4838         enddo
4839         emin=0.5D0*emin
4840 cd      print *,'it=',it,' emin=',emin
4841
4842 C Compute the contribution to SC energy and derivatives
4843         do iii=-1,1
4844
4845           do j=1,nlobit
4846             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4847 cd          print *,'j=',j,' expfac=',expfac
4848             escloc_i=escloc_i+expfac
4849             do k=1,3
4850               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4851             enddo
4852             if (mixed) then
4853               do k=1,3,2
4854                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4855      &            +gaussc(k,2,j,it))*expfac
4856               enddo
4857             endif
4858           enddo
4859
4860         enddo ! iii
4861
4862         dersc(1)=dersc(1)/cos(theti)**2
4863         ddersc(1)=ddersc(1)/cos(theti)**2
4864         ddersc(3)=ddersc(3)
4865
4866         escloci=-(dlog(escloc_i)-emin)
4867         do j=1,3
4868           dersc(j)=dersc(j)/escloc_i
4869         enddo
4870         if (mixed) then
4871           do j=1,3,2
4872             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4873           enddo
4874         endif
4875       return
4876       end
4877 C------------------------------------------------------------------------------
4878       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4879       implicit real*8 (a-h,o-z)
4880       include 'DIMENSIONS'
4881       include 'COMMON.GEO'
4882       include 'COMMON.LOCAL'
4883       include 'COMMON.IOUNITS'
4884       common /sccalc/ time11,time12,time112,theti,it,nlobit
4885       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4886       double precision contr(maxlob)
4887       logical mixed
4888
4889       escloc_i=0.0D0
4890
4891       do j=1,3
4892         dersc(j)=0.0D0
4893       enddo
4894
4895       do j=1,nlobit
4896         do k=1,2
4897           z(k)=x(k)-censc(k,j,it)
4898         enddo
4899         z(3)=dwapi
4900         do k=1,3
4901           Axk=0.0D0
4902           do l=1,3
4903             Axk=Axk+gaussc(l,k,j,it)*z(l)
4904           enddo
4905           Ax(k,j)=Axk
4906         enddo
4907         expfac=0.0D0
4908         do k=1,3
4909           expfac=expfac+Ax(k,j)*z(k)
4910         enddo
4911         contr(j)=expfac
4912       enddo ! j
4913
4914 C As in the case of ebend, we want to avoid underflows in exponentiation and
4915 C subsequent NaNs and INFs in energy calculation.
4916 C Find the largest exponent
4917       emin=contr(1)
4918       do j=1,nlobit
4919         if (emin.gt.contr(j)) emin=contr(j)
4920       enddo
4921       emin=0.5D0*emin
4922
4923 C Compute the contribution to SC energy and derivatives
4924
4925       dersc12=0.0d0
4926       do j=1,nlobit
4927         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4928         escloc_i=escloc_i+expfac
4929         do k=1,2
4930           dersc(k)=dersc(k)+Ax(k,j)*expfac
4931         enddo
4932         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4933      &            +gaussc(1,2,j,it))*expfac
4934         dersc(3)=0.0d0
4935       enddo
4936
4937       dersc(1)=dersc(1)/cos(theti)**2
4938       dersc12=dersc12/cos(theti)**2
4939       escloci=-(dlog(escloc_i)-emin)
4940       do j=1,2
4941         dersc(j)=dersc(j)/escloc_i
4942       enddo
4943       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4944       return
4945       end
4946 #else
4947 c----------------------------------------------------------------------------------
4948       subroutine esc(escloc)
4949 C Calculate the local energy of a side chain and its derivatives in the
4950 C corresponding virtual-bond valence angles THETA and the spherical angles
4951 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4952 C added by Urszula Kozlowska. 07/11/2007
4953 C
4954       implicit real*8 (a-h,o-z)
4955       include 'DIMENSIONS'
4956       include 'DIMENSIONS.ZSCOPT'
4957       include 'DIMENSIONS.FREE'
4958       include 'COMMON.GEO'
4959       include 'COMMON.LOCAL'
4960       include 'COMMON.VAR'
4961       include 'COMMON.SCROT'
4962       include 'COMMON.INTERACT'
4963       include 'COMMON.DERIV'
4964       include 'COMMON.CHAIN'
4965       include 'COMMON.IOUNITS'
4966       include 'COMMON.NAMES'
4967       include 'COMMON.FFIELD'
4968       include 'COMMON.CONTROL'
4969       include 'COMMON.VECTORS'
4970       double precision x_prime(3),y_prime(3),z_prime(3)
4971      &    , sumene,dsc_i,dp2_i,x(65),
4972      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4973      &    de_dxx,de_dyy,de_dzz,de_dt
4974       double precision s1_t,s1_6_t,s2_t,s2_6_t
4975       double precision
4976      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4977      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4978      & dt_dCi(3),dt_dCi1(3)
4979       common /sccalc/ time11,time12,time112,theti,it,nlobit
4980       delta=0.02d0*pi
4981       escloc=0.0D0
4982       do i=loc_start,loc_end
4983         if (itype(i).eq.ntyp1) cycle
4984         costtab(i+1) =dcos(theta(i+1))
4985         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4986         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4987         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4988         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4989         cosfac=dsqrt(cosfac2)
4990         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4991         sinfac=dsqrt(sinfac2)
4992         it=iabs(itype(i))
4993         if (it.eq.10) goto 1
4994 c
4995 C  Compute the axes of tghe local cartesian coordinates system; store in
4996 c   x_prime, y_prime and z_prime
4997 c
4998         do j=1,3
4999           x_prime(j) = 0.00
5000           y_prime(j) = 0.00
5001           z_prime(j) = 0.00
5002         enddo
5003 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5004 C     &   dc_norm(3,i+nres)
5005         do j = 1,3
5006           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5007           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5008         enddo
5009         do j = 1,3
5010           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5011         enddo
5012 c       write (2,*) "i",i
5013 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5014 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5015 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5016 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5017 c      & " xy",scalar(x_prime(1),y_prime(1)),
5018 c      & " xz",scalar(x_prime(1),z_prime(1)),
5019 c      & " yy",scalar(y_prime(1),y_prime(1)),
5020 c      & " yz",scalar(y_prime(1),z_prime(1)),
5021 c      & " zz",scalar(z_prime(1),z_prime(1))
5022 c
5023 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5024 C to local coordinate system. Store in xx, yy, zz.
5025 c
5026         xx=0.0d0
5027         yy=0.0d0
5028         zz=0.0d0
5029         do j = 1,3
5030           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5031           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5032           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5033         enddo
5034
5035         xxtab(i)=xx
5036         yytab(i)=yy
5037         zztab(i)=zz
5038 C
5039 C Compute the energy of the ith side cbain
5040 C
5041 c        write (2,*) "xx",xx," yy",yy," zz",zz
5042         it=iabs(itype(i))
5043         do j = 1,65
5044           x(j) = sc_parmin(j,it)
5045         enddo
5046 #ifdef CHECK_COORD
5047 Cc diagnostics - remove later
5048         xx1 = dcos(alph(2))
5049         yy1 = dsin(alph(2))*dcos(omeg(2))
5050         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5051         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5052      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5053      &    xx1,yy1,zz1
5054 C,"  --- ", xx_w,yy_w,zz_w
5055 c end diagnostics
5056 #endif
5057         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5058      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5059      &   + x(10)*yy*zz
5060         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5061      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5062      & + x(20)*yy*zz
5063         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5064      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5065      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5066      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5067      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5068      &  +x(40)*xx*yy*zz
5069         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5070      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5071      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5072      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5073      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5074      &  +x(60)*xx*yy*zz
5075         dsc_i   = 0.743d0+x(61)
5076         dp2_i   = 1.9d0+x(62)
5077         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5078      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5079         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5080      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5081         s1=(1+x(63))/(0.1d0 + dscp1)
5082         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5083         s2=(1+x(65))/(0.1d0 + dscp2)
5084         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5085         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5086      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5087 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5088 c     &   sumene4,
5089 c     &   dscp1,dscp2,sumene
5090 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5091         escloc = escloc + sumene
5092 c        write (2,*) "escloc",escloc
5093 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5094 c     &  zz,xx,yy
5095         if (.not. calc_grad) goto 1
5096 #ifdef DEBUG
5097 C
5098 C This section to check the numerical derivatives of the energy of ith side
5099 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5100 C #define DEBUG in the code to turn it on.
5101 C
5102         write (2,*) "sumene               =",sumene
5103         aincr=1.0d-7
5104         xxsave=xx
5105         xx=xx+aincr
5106         write (2,*) xx,yy,zz
5107         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5108         de_dxx_num=(sumenep-sumene)/aincr
5109         xx=xxsave
5110         write (2,*) "xx+ sumene from enesc=",sumenep
5111         yysave=yy
5112         yy=yy+aincr
5113         write (2,*) xx,yy,zz
5114         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5115         de_dyy_num=(sumenep-sumene)/aincr
5116         yy=yysave
5117         write (2,*) "yy+ sumene from enesc=",sumenep
5118         zzsave=zz
5119         zz=zz+aincr
5120         write (2,*) xx,yy,zz
5121         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5122         de_dzz_num=(sumenep-sumene)/aincr
5123         zz=zzsave
5124         write (2,*) "zz+ sumene from enesc=",sumenep
5125         costsave=cost2tab(i+1)
5126         sintsave=sint2tab(i+1)
5127         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5128         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5129         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5130         de_dt_num=(sumenep-sumene)/aincr
5131         write (2,*) " t+ sumene from enesc=",sumenep
5132         cost2tab(i+1)=costsave
5133         sint2tab(i+1)=sintsave
5134 C End of diagnostics section.
5135 #endif
5136 C
5137 C Compute the gradient of esc
5138 C
5139         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5140         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5141         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5142         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5143         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5144         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5145         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5146         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5147         pom1=(sumene3*sint2tab(i+1)+sumene1)
5148      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5149         pom2=(sumene4*cost2tab(i+1)+sumene2)
5150      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5151         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5152         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5153      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5154      &  +x(40)*yy*zz
5155         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5156         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5157      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5158      &  +x(60)*yy*zz
5159         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5160      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5161      &        +(pom1+pom2)*pom_dx
5162 #ifdef DEBUG
5163         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5164 #endif
5165 C
5166         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5167         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5168      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5169      &  +x(40)*xx*zz
5170         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5171         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5172      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5173      &  +x(59)*zz**2 +x(60)*xx*zz
5174         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5175      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5176      &        +(pom1-pom2)*pom_dy
5177 #ifdef DEBUG
5178         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5179 #endif
5180 C
5181         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5182      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5183      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5184      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5185      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5186      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5187      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5188      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5189 #ifdef DEBUG
5190         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5191 #endif
5192 C
5193         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5194      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5195      &  +pom1*pom_dt1+pom2*pom_dt2
5196 #ifdef DEBUG
5197         write(2,*), "de_dt = ", de_dt,de_dt_num
5198 #endif
5199 c
5200 C
5201        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5202        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5203        cosfac2xx=cosfac2*xx
5204        sinfac2yy=sinfac2*yy
5205        do k = 1,3
5206          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5207      &      vbld_inv(i+1)
5208          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5209      &      vbld_inv(i)
5210          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5211          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5212 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5213 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5214 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5215 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5216          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5217          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5218          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5219          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5220          dZZ_Ci1(k)=0.0d0
5221          dZZ_Ci(k)=0.0d0
5222          do j=1,3
5223            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5224      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5225            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5226      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5227          enddo
5228
5229          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5230          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5231          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5232 c
5233          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5234          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5235        enddo
5236
5237        do k=1,3
5238          dXX_Ctab(k,i)=dXX_Ci(k)
5239          dXX_C1tab(k,i)=dXX_Ci1(k)
5240          dYY_Ctab(k,i)=dYY_Ci(k)
5241          dYY_C1tab(k,i)=dYY_Ci1(k)
5242          dZZ_Ctab(k,i)=dZZ_Ci(k)
5243          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5244          dXX_XYZtab(k,i)=dXX_XYZ(k)
5245          dYY_XYZtab(k,i)=dYY_XYZ(k)
5246          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5247        enddo
5248
5249        do k = 1,3
5250 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5251 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5252 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5253 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5254 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5255 c     &    dt_dci(k)
5256 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5257 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5258          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5259      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5260          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5261      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5262          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5263      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5264        enddo
5265 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5266 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5267
5268 C to check gradient call subroutine check_grad
5269
5270     1 continue
5271       enddo
5272       return
5273       end
5274 #endif
5275 c------------------------------------------------------------------------------
5276       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5277 C
5278 C This procedure calculates two-body contact function g(rij) and its derivative:
5279 C
5280 C           eps0ij                                     !       x < -1
5281 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5282 C            0                                         !       x > 1
5283 C
5284 C where x=(rij-r0ij)/delta
5285 C
5286 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5287 C
5288       implicit none
5289       double precision rij,r0ij,eps0ij,fcont,fprimcont
5290       double precision x,x2,x4,delta
5291 c     delta=0.02D0*r0ij
5292 c      delta=0.2D0*r0ij
5293       x=(rij-r0ij)/delta
5294       if (x.lt.-1.0D0) then
5295         fcont=eps0ij
5296         fprimcont=0.0D0
5297       else if (x.le.1.0D0) then
5298         x2=x*x
5299         x4=x2*x2
5300         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5301         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5302       else
5303         fcont=0.0D0
5304         fprimcont=0.0D0
5305       endif
5306       return
5307       end
5308 c------------------------------------------------------------------------------
5309       subroutine splinthet(theti,delta,ss,ssder)
5310       implicit real*8 (a-h,o-z)
5311       include 'DIMENSIONS'
5312       include 'DIMENSIONS.ZSCOPT'
5313       include 'COMMON.VAR'
5314       include 'COMMON.GEO'
5315       thetup=pi-delta
5316       thetlow=delta
5317       if (theti.gt.pipol) then
5318         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5319       else
5320         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5321         ssder=-ssder
5322       endif
5323       return
5324       end
5325 c------------------------------------------------------------------------------
5326       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5327       implicit none
5328       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5329       double precision ksi,ksi2,ksi3,a1,a2,a3
5330       a1=fprim0*delta/(f1-f0)
5331       a2=3.0d0-2.0d0*a1
5332       a3=a1-2.0d0
5333       ksi=(x-x0)/delta
5334       ksi2=ksi*ksi
5335       ksi3=ksi2*ksi
5336       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5337       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5338       return
5339       end
5340 c------------------------------------------------------------------------------
5341       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5342       implicit none
5343       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5344       double precision ksi,ksi2,ksi3,a1,a2,a3
5345       ksi=(x-x0)/delta
5346       ksi2=ksi*ksi
5347       ksi3=ksi2*ksi
5348       a1=fprim0x*delta
5349       a2=3*(f1x-f0x)-2*fprim0x*delta
5350       a3=fprim0x*delta-2*(f1x-f0x)
5351       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5352       return
5353       end
5354 C-----------------------------------------------------------------------------
5355 #ifdef CRYST_TOR
5356 C-----------------------------------------------------------------------------
5357       subroutine etor(etors,edihcnstr,fact)
5358       implicit real*8 (a-h,o-z)
5359       include 'DIMENSIONS'
5360       include 'DIMENSIONS.ZSCOPT'
5361       include 'COMMON.VAR'
5362       include 'COMMON.GEO'
5363       include 'COMMON.LOCAL'
5364       include 'COMMON.TORSION'
5365       include 'COMMON.INTERACT'
5366       include 'COMMON.DERIV'
5367       include 'COMMON.CHAIN'
5368       include 'COMMON.NAMES'
5369       include 'COMMON.IOUNITS'
5370       include 'COMMON.FFIELD'
5371       include 'COMMON.TORCNSTR'
5372       logical lprn
5373 C Set lprn=.true. for debugging
5374       lprn=.false.
5375 c      lprn=.true.
5376       etors=0.0D0
5377       do i=iphi_start,iphi_end
5378         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5379      &      .or. itype(i).eq.ntyp1) cycle
5380         itori=itortyp(itype(i-2))
5381         itori1=itortyp(itype(i-1))
5382         phii=phi(i)
5383         gloci=0.0D0
5384 C Proline-Proline pair is a special case...
5385         if (itori.eq.3 .and. itori1.eq.3) then
5386           if (phii.gt.-dwapi3) then
5387             cosphi=dcos(3*phii)
5388             fac=1.0D0/(1.0D0-cosphi)
5389             etorsi=v1(1,3,3)*fac
5390             etorsi=etorsi+etorsi
5391             etors=etors+etorsi-v1(1,3,3)
5392             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5393           endif
5394           do j=1,3
5395             v1ij=v1(j+1,itori,itori1)
5396             v2ij=v2(j+1,itori,itori1)
5397             cosphi=dcos(j*phii)
5398             sinphi=dsin(j*phii)
5399             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5400             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5401           enddo
5402         else
5403           do j=1,nterm_old
5404             v1ij=v1(j,itori,itori1)
5405             v2ij=v2(j,itori,itori1)
5406             cosphi=dcos(j*phii)
5407             sinphi=dsin(j*phii)
5408             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5409             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5410           enddo
5411         endif
5412         if (lprn)
5413      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5414      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5415      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5416         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5417 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5418       enddo
5419 ! 6/20/98 - dihedral angle constraints
5420       edihcnstr=0.0d0
5421       do i=1,ndih_constr
5422         itori=idih_constr(i)
5423         phii=phi(itori)
5424         difi=phii-phi0(i)
5425         if (difi.gt.drange(i)) then
5426           difi=difi-drange(i)
5427           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5428           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5429         else if (difi.lt.-drange(i)) then
5430           difi=difi+drange(i)
5431           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5432           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5433         endif
5434 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5435 C     &    i,itori,rad2deg*phii,
5436 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5437       enddo
5438 !      write (iout,*) 'edihcnstr',edihcnstr
5439       return
5440       end
5441 c------------------------------------------------------------------------------
5442 #else
5443       subroutine etor(etors,edihcnstr,fact)
5444       implicit real*8 (a-h,o-z)
5445       include 'DIMENSIONS'
5446       include 'DIMENSIONS.ZSCOPT'
5447       include 'COMMON.VAR'
5448       include 'COMMON.GEO'
5449       include 'COMMON.LOCAL'
5450       include 'COMMON.TORSION'
5451       include 'COMMON.INTERACT'
5452       include 'COMMON.DERIV'
5453       include 'COMMON.CHAIN'
5454       include 'COMMON.NAMES'
5455       include 'COMMON.IOUNITS'
5456       include 'COMMON.FFIELD'
5457       include 'COMMON.TORCNSTR'
5458       logical lprn
5459 C Set lprn=.true. for debugging
5460       lprn=.false.
5461 c      lprn=.true.
5462       etors=0.0D0
5463       do i=iphi_start,iphi_end
5464         if (i.le.2) cycle
5465         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5466      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5467 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5468 C     &       .or. itype(i).eq.ntyp1) cycle
5469         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5470          if (iabs(itype(i)).eq.20) then
5471          iblock=2
5472          else
5473          iblock=1
5474          endif
5475         itori=itortyp(itype(i-2))
5476         itori1=itortyp(itype(i-1))
5477         phii=phi(i)
5478         gloci=0.0D0
5479 C Regular cosine and sine terms
5480         do j=1,nterm(itori,itori1,iblock)
5481           v1ij=v1(j,itori,itori1,iblock)
5482           v2ij=v2(j,itori,itori1,iblock)
5483           cosphi=dcos(j*phii)
5484           sinphi=dsin(j*phii)
5485           etors=etors+v1ij*cosphi+v2ij*sinphi
5486           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5487         enddo
5488 C Lorentz terms
5489 C                         v1
5490 C  E = SUM ----------------------------------- - v1
5491 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5492 C
5493         cosphi=dcos(0.5d0*phii)
5494         sinphi=dsin(0.5d0*phii)
5495         do j=1,nlor(itori,itori1,iblock)
5496           vl1ij=vlor1(j,itori,itori1)
5497           vl2ij=vlor2(j,itori,itori1)
5498           vl3ij=vlor3(j,itori,itori1)
5499           pom=vl2ij*cosphi+vl3ij*sinphi
5500           pom1=1.0d0/(pom*pom+1.0d0)
5501           etors=etors+vl1ij*pom1
5502 c          if (energy_dec) etors_ii=etors_ii+
5503 c     &                vl1ij*pom1
5504           pom=-pom*pom1*pom1
5505           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5506         enddo
5507 C Subtract the constant term
5508         etors=etors-v0(itori,itori1,iblock)
5509         if (lprn)
5510      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5511      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5512      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5513         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5514 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5515  1215   continue
5516       enddo
5517 ! 6/20/98 - dihedral angle constraints
5518       edihcnstr=0.0d0
5519       do i=1,ndih_constr
5520         itori=idih_constr(i)
5521         phii=phi(itori)
5522         difi=pinorm(phii-phi0(i))
5523         edihi=0.0d0
5524         if (difi.gt.drange(i)) then
5525           difi=difi-drange(i)
5526           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5527           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5528           edihi=0.25d0*ftors(i)*difi**4
5529         else if (difi.lt.-drange(i)) then
5530           difi=difi+drange(i)
5531           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5532           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5533           edihi=0.25d0*ftors(i)*difi**4
5534         else
5535           difi=0.0d0
5536         endif
5537         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5538      &    i,itori,rad2deg*phii,
5539      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5540 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5541 c     &    drange(i),edihi
5542 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5543 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5544       enddo
5545 !      write (iout,*) 'edihcnstr',edihcnstr
5546       return
5547       end
5548 c----------------------------------------------------------------------------
5549       subroutine etor_d(etors_d,fact2)
5550 C 6/23/01 Compute double torsional energy
5551       implicit real*8 (a-h,o-z)
5552       include 'DIMENSIONS'
5553       include 'DIMENSIONS.ZSCOPT'
5554       include 'COMMON.VAR'
5555       include 'COMMON.GEO'
5556       include 'COMMON.LOCAL'
5557       include 'COMMON.TORSION'
5558       include 'COMMON.INTERACT'
5559       include 'COMMON.DERIV'
5560       include 'COMMON.CHAIN'
5561       include 'COMMON.NAMES'
5562       include 'COMMON.IOUNITS'
5563       include 'COMMON.FFIELD'
5564       include 'COMMON.TORCNSTR'
5565       logical lprn
5566 C Set lprn=.true. for debugging
5567       lprn=.false.
5568 c     lprn=.true.
5569       etors_d=0.0D0
5570       do i=iphi_start,iphi_end-1
5571         if (i.le.3) cycle
5572 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5573 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5574          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5575      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5576      &  (itype(i+1).eq.ntyp1)) cycle
5577         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5578      &     goto 1215
5579         itori=itortyp(itype(i-2))
5580         itori1=itortyp(itype(i-1))
5581         itori2=itortyp(itype(i))
5582         phii=phi(i)
5583         phii1=phi(i+1)
5584         gloci1=0.0D0
5585         gloci2=0.0D0
5586         iblock=1
5587         if (iabs(itype(i+1)).eq.20) iblock=2
5588 C Regular cosine and sine terms
5589         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5590           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5591           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5592           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5593           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5594           cosphi1=dcos(j*phii)
5595           sinphi1=dsin(j*phii)
5596           cosphi2=dcos(j*phii1)
5597           sinphi2=dsin(j*phii1)
5598           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5599      &     v2cij*cosphi2+v2sij*sinphi2
5600           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5601           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5602         enddo
5603         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5604           do l=1,k-1
5605             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5606             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5607             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5608             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5609             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5610             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5611             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5612             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5613             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5614      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5615             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5616      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5617             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5618      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5619           enddo
5620         enddo
5621         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5622         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5623  1215   continue
5624       enddo
5625       return
5626       end
5627 #endif
5628 c------------------------------------------------------------------------------
5629       subroutine eback_sc_corr(esccor)
5630 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5631 c        conformational states; temporarily implemented as differences
5632 c        between UNRES torsional potentials (dependent on three types of
5633 c        residues) and the torsional potentials dependent on all 20 types
5634 c        of residues computed from AM1 energy surfaces of terminally-blocked
5635 c        amino-acid residues.
5636       implicit real*8 (a-h,o-z)
5637       include 'DIMENSIONS'
5638       include 'DIMENSIONS.ZSCOPT'
5639       include 'DIMENSIONS.FREE'
5640       include 'COMMON.VAR'
5641       include 'COMMON.GEO'
5642       include 'COMMON.LOCAL'
5643       include 'COMMON.TORSION'
5644       include 'COMMON.SCCOR'
5645       include 'COMMON.INTERACT'
5646       include 'COMMON.DERIV'
5647       include 'COMMON.CHAIN'
5648       include 'COMMON.NAMES'
5649       include 'COMMON.IOUNITS'
5650       include 'COMMON.FFIELD'
5651       include 'COMMON.CONTROL'
5652       logical lprn
5653 C Set lprn=.true. for debugging
5654       lprn=.false.
5655 c      lprn=.true.
5656 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5657       esccor=0.0D0
5658       do i=itau_start,itau_end
5659         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5660         esccor_ii=0.0D0
5661         isccori=isccortyp(itype(i-2))
5662         isccori1=isccortyp(itype(i-1))
5663         phii=phi(i)
5664         do intertyp=1,3 !intertyp
5665 cc Added 09 May 2012 (Adasko)
5666 cc  Intertyp means interaction type of backbone mainchain correlation:
5667 c   1 = SC...Ca...Ca...Ca
5668 c   2 = Ca...Ca...Ca...SC
5669 c   3 = SC...Ca...Ca...SCi
5670         gloci=0.0D0
5671         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5672      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5673      &      (itype(i-1).eq.ntyp1)))
5674      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5675      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5676      &     .or.(itype(i).eq.ntyp1)))
5677      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5678      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5679      &      (itype(i-3).eq.ntyp1)))) cycle
5680         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5681         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5682      & cycle
5683        do j=1,nterm_sccor(isccori,isccori1)
5684           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5685           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5686           cosphi=dcos(j*tauangle(intertyp,i))
5687           sinphi=dsin(j*tauangle(intertyp,i))
5688            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5689            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5690          enddo
5691 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5692 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5693 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5694         if (lprn)
5695      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5696      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5697      &  (v1sccor(j,1,itori,itori1),j=1,6)
5698      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5699 c        gsccor_loc(i-3)=gloci
5700        enddo !intertyp
5701       enddo
5702       return
5703       end
5704 c------------------------------------------------------------------------------
5705       subroutine multibody(ecorr)
5706 C This subroutine calculates multi-body contributions to energy following
5707 C the idea of Skolnick et al. If side chains I and J make a contact and
5708 C at the same time side chains I+1 and J+1 make a contact, an extra
5709 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5710       implicit real*8 (a-h,o-z)
5711       include 'DIMENSIONS'
5712       include 'COMMON.IOUNITS'
5713       include 'COMMON.DERIV'
5714       include 'COMMON.INTERACT'
5715       include 'COMMON.CONTACTS'
5716       double precision gx(3),gx1(3)
5717       logical lprn
5718
5719 C Set lprn=.true. for debugging
5720       lprn=.false.
5721
5722       if (lprn) then
5723         write (iout,'(a)') 'Contact function values:'
5724         do i=nnt,nct-2
5725           write (iout,'(i2,20(1x,i2,f10.5))')
5726      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5727         enddo
5728       endif
5729       ecorr=0.0D0
5730       do i=nnt,nct
5731         do j=1,3
5732           gradcorr(j,i)=0.0D0
5733           gradxorr(j,i)=0.0D0
5734         enddo
5735       enddo
5736       do i=nnt,nct-2
5737
5738         DO ISHIFT = 3,4
5739
5740         i1=i+ishift
5741         num_conti=num_cont(i)
5742         num_conti1=num_cont(i1)
5743         do jj=1,num_conti
5744           j=jcont(jj,i)
5745           do kk=1,num_conti1
5746             j1=jcont(kk,i1)
5747             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5748 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5749 cd   &                   ' ishift=',ishift
5750 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5751 C The system gains extra energy.
5752               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5753             endif   ! j1==j+-ishift
5754           enddo     ! kk
5755         enddo       ! jj
5756
5757         ENDDO ! ISHIFT
5758
5759       enddo         ! i
5760       return
5761       end
5762 c------------------------------------------------------------------------------
5763       double precision function esccorr(i,j,k,l,jj,kk)
5764       implicit real*8 (a-h,o-z)
5765       include 'DIMENSIONS'
5766       include 'COMMON.IOUNITS'
5767       include 'COMMON.DERIV'
5768       include 'COMMON.INTERACT'
5769       include 'COMMON.CONTACTS'
5770       double precision gx(3),gx1(3)
5771       logical lprn
5772       lprn=.false.
5773       eij=facont(jj,i)
5774       ekl=facont(kk,k)
5775 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5776 C Calculate the multi-body contribution to energy.
5777 C Calculate multi-body contributions to the gradient.
5778 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5779 cd   & k,l,(gacont(m,kk,k),m=1,3)
5780       do m=1,3
5781         gx(m) =ekl*gacont(m,jj,i)
5782         gx1(m)=eij*gacont(m,kk,k)
5783         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5784         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5785         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5786         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5787       enddo
5788       do m=i,j-1
5789         do ll=1,3
5790           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5791         enddo
5792       enddo
5793       do m=k,l-1
5794         do ll=1,3
5795           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5796         enddo
5797       enddo
5798       esccorr=-eij*ekl
5799       return
5800       end
5801 c------------------------------------------------------------------------------
5802 #ifdef MPL
5803       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5804       implicit real*8 (a-h,o-z)
5805       include 'DIMENSIONS'
5806       integer dimen1,dimen2,atom,indx
5807       double precision buffer(dimen1,dimen2)
5808       double precision zapas
5809       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5810      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5811      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5812       num_kont=num_cont_hb(atom)
5813       do i=1,num_kont
5814         do k=1,7
5815           do j=1,3
5816             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5817           enddo ! j
5818         enddo ! k
5819         buffer(i,indx+22)=facont_hb(i,atom)
5820         buffer(i,indx+23)=ees0p(i,atom)
5821         buffer(i,indx+24)=ees0m(i,atom)
5822         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5823       enddo ! i
5824       buffer(1,indx+26)=dfloat(num_kont)
5825       return
5826       end
5827 c------------------------------------------------------------------------------
5828       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5829       implicit real*8 (a-h,o-z)
5830       include 'DIMENSIONS'
5831       integer dimen1,dimen2,atom,indx
5832       double precision buffer(dimen1,dimen2)
5833       double precision zapas
5834       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5835      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5836      &         ees0m(ntyp,maxres),
5837      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5838       num_kont=buffer(1,indx+26)
5839       num_kont_old=num_cont_hb(atom)
5840       num_cont_hb(atom)=num_kont+num_kont_old
5841       do i=1,num_kont
5842         ii=i+num_kont_old
5843         do k=1,7
5844           do j=1,3
5845             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5846           enddo ! j
5847         enddo ! k
5848         facont_hb(ii,atom)=buffer(i,indx+22)
5849         ees0p(ii,atom)=buffer(i,indx+23)
5850         ees0m(ii,atom)=buffer(i,indx+24)
5851         jcont_hb(ii,atom)=buffer(i,indx+25)
5852       enddo ! i
5853       return
5854       end
5855 c------------------------------------------------------------------------------
5856 #endif
5857       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5858 C This subroutine calculates multi-body contributions to hydrogen-bonding
5859       implicit real*8 (a-h,o-z)
5860       include 'DIMENSIONS'
5861       include 'DIMENSIONS.ZSCOPT'
5862       include 'COMMON.IOUNITS'
5863 #ifdef MPL
5864       include 'COMMON.INFO'
5865 #endif
5866       include 'COMMON.FFIELD'
5867       include 'COMMON.DERIV'
5868       include 'COMMON.INTERACT'
5869       include 'COMMON.CONTACTS'
5870 #ifdef MPL
5871       parameter (max_cont=maxconts)
5872       parameter (max_dim=2*(8*3+2))
5873       parameter (msglen1=max_cont*max_dim*4)
5874       parameter (msglen2=2*msglen1)
5875       integer source,CorrelType,CorrelID,Error
5876       double precision buffer(max_cont,max_dim)
5877 #endif
5878       double precision gx(3),gx1(3)
5879       logical lprn,ldone
5880
5881 C Set lprn=.true. for debugging
5882       lprn=.false.
5883 #ifdef MPL
5884       n_corr=0
5885       n_corr1=0
5886       if (fgProcs.le.1) goto 30
5887       if (lprn) then
5888         write (iout,'(a)') 'Contact function values:'
5889         do i=nnt,nct-2
5890           write (iout,'(2i3,50(1x,i2,f5.2))')
5891      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5892      &    j=1,num_cont_hb(i))
5893         enddo
5894       endif
5895 C Caution! Following code assumes that electrostatic interactions concerning
5896 C a given atom are split among at most two processors!
5897       CorrelType=477
5898       CorrelID=MyID+1
5899       ldone=.false.
5900       do i=1,max_cont
5901         do j=1,max_dim
5902           buffer(i,j)=0.0D0
5903         enddo
5904       enddo
5905       mm=mod(MyRank,2)
5906 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5907       if (mm) 20,20,10
5908    10 continue
5909 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5910       if (MyRank.gt.0) then
5911 C Send correlation contributions to the preceding processor
5912         msglen=msglen1
5913         nn=num_cont_hb(iatel_s)
5914         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5915 cd      write (iout,*) 'The BUFFER array:'
5916 cd      do i=1,nn
5917 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5918 cd      enddo
5919         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5920           msglen=msglen2
5921             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5922 C Clear the contacts of the atom passed to the neighboring processor
5923         nn=num_cont_hb(iatel_s+1)
5924 cd      do i=1,nn
5925 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5926 cd      enddo
5927             num_cont_hb(iatel_s)=0
5928         endif
5929 cd      write (iout,*) 'Processor ',MyID,MyRank,
5930 cd   & ' is sending correlation contribution to processor',MyID-1,
5931 cd   & ' msglen=',msglen
5932 cd      write (*,*) 'Processor ',MyID,MyRank,
5933 cd   & ' is sending correlation contribution to processor',MyID-1,
5934 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5935         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5936 cd      write (iout,*) 'Processor ',MyID,
5937 cd   & ' has sent correlation contribution to processor',MyID-1,
5938 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5939 cd      write (*,*) 'Processor ',MyID,
5940 cd   & ' has sent correlation contribution to processor',MyID-1,
5941 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5942         msglen=msglen1
5943       endif ! (MyRank.gt.0)
5944       if (ldone) goto 30
5945       ldone=.true.
5946    20 continue
5947 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5948       if (MyRank.lt.fgProcs-1) then
5949 C Receive correlation contributions from the next processor
5950         msglen=msglen1
5951         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5952 cd      write (iout,*) 'Processor',MyID,
5953 cd   & ' is receiving correlation contribution from processor',MyID+1,
5954 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5955 cd      write (*,*) 'Processor',MyID,
5956 cd   & ' is receiving correlation contribution from processor',MyID+1,
5957 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5958         nbytes=-1
5959         do while (nbytes.le.0)
5960           call mp_probe(MyID+1,CorrelType,nbytes)
5961         enddo
5962 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5963         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5964 cd      write (iout,*) 'Processor',MyID,
5965 cd   & ' has received correlation contribution from processor',MyID+1,
5966 cd   & ' msglen=',msglen,' nbytes=',nbytes
5967 cd      write (iout,*) 'The received BUFFER array:'
5968 cd      do i=1,max_cont
5969 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5970 cd      enddo
5971         if (msglen.eq.msglen1) then
5972           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5973         else if (msglen.eq.msglen2)  then
5974           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5975           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5976         else
5977           write (iout,*)
5978      & 'ERROR!!!! message length changed while processing correlations.'
5979           write (*,*)
5980      & 'ERROR!!!! message length changed while processing correlations.'
5981           call mp_stopall(Error)
5982         endif ! msglen.eq.msglen1
5983       endif ! MyRank.lt.fgProcs-1
5984       if (ldone) goto 30
5985       ldone=.true.
5986       goto 10
5987    30 continue
5988 #endif
5989       if (lprn) then
5990         write (iout,'(a)') 'Contact function values:'
5991         do i=nnt,nct-2
5992           write (iout,'(2i3,50(1x,i2,f5.2))')
5993      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5994      &    j=1,num_cont_hb(i))
5995         enddo
5996       endif
5997       ecorr=0.0D0
5998 C Remove the loop below after debugging !!!
5999       do i=nnt,nct
6000         do j=1,3
6001           gradcorr(j,i)=0.0D0
6002           gradxorr(j,i)=0.0D0
6003         enddo
6004       enddo
6005 C Calculate the local-electrostatic correlation terms
6006       do i=iatel_s,iatel_e+1
6007         i1=i+1
6008         num_conti=num_cont_hb(i)
6009         num_conti1=num_cont_hb(i+1)
6010         do jj=1,num_conti
6011           j=jcont_hb(jj,i)
6012           do kk=1,num_conti1
6013             j1=jcont_hb(kk,i1)
6014 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6015 c     &         ' jj=',jj,' kk=',kk
6016             if (j1.eq.j+1 .or. j1.eq.j-1) then
6017 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6018 C The system gains extra energy.
6019               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6020               n_corr=n_corr+1
6021             else if (j1.eq.j) then
6022 C Contacts I-J and I-(J+1) occur simultaneously.
6023 C The system loses extra energy.
6024 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6025             endif
6026           enddo ! kk
6027           do kk=1,num_conti
6028             j1=jcont_hb(kk,i)
6029 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6030 c    &         ' jj=',jj,' kk=',kk
6031             if (j1.eq.j+1) then
6032 C Contacts I-J and (I+1)-J occur simultaneously.
6033 C The system loses extra energy.
6034 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6035             endif ! j1==j+1
6036           enddo ! kk
6037         enddo ! jj
6038       enddo ! i
6039       return
6040       end
6041 c------------------------------------------------------------------------------
6042       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6043      &  n_corr1)
6044 C This subroutine calculates multi-body contributions to hydrogen-bonding
6045       implicit real*8 (a-h,o-z)
6046       include 'DIMENSIONS'
6047       include 'DIMENSIONS.ZSCOPT'
6048       include 'COMMON.IOUNITS'
6049 #ifdef MPL
6050       include 'COMMON.INFO'
6051 #endif
6052       include 'COMMON.FFIELD'
6053       include 'COMMON.DERIV'
6054       include 'COMMON.INTERACT'
6055       include 'COMMON.CONTACTS'
6056 #ifdef MPL
6057       parameter (max_cont=maxconts)
6058       parameter (max_dim=2*(8*3+2))
6059       parameter (msglen1=max_cont*max_dim*4)
6060       parameter (msglen2=2*msglen1)
6061       integer source,CorrelType,CorrelID,Error
6062       double precision buffer(max_cont,max_dim)
6063 #endif
6064       double precision gx(3),gx1(3)
6065       logical lprn,ldone
6066
6067 C Set lprn=.true. for debugging
6068       lprn=.false.
6069       eturn6=0.0d0
6070       ecorr6=0.0d0
6071 #ifdef MPL
6072       n_corr=0
6073       n_corr1=0
6074       if (fgProcs.le.1) goto 30
6075       if (lprn) then
6076         write (iout,'(a)') 'Contact function values:'
6077         do i=nnt,nct-2
6078           write (iout,'(2i3,50(1x,i2,f5.2))')
6079      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6080      &    j=1,num_cont_hb(i))
6081         enddo
6082       endif
6083 C Caution! Following code assumes that electrostatic interactions concerning
6084 C a given atom are split among at most two processors!
6085       CorrelType=477
6086       CorrelID=MyID+1
6087       ldone=.false.
6088       do i=1,max_cont
6089         do j=1,max_dim
6090           buffer(i,j)=0.0D0
6091         enddo
6092       enddo
6093       mm=mod(MyRank,2)
6094 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6095       if (mm) 20,20,10
6096    10 continue
6097 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6098       if (MyRank.gt.0) then
6099 C Send correlation contributions to the preceding processor
6100         msglen=msglen1
6101         nn=num_cont_hb(iatel_s)
6102         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6103 cd      write (iout,*) 'The BUFFER array:'
6104 cd      do i=1,nn
6105 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6106 cd      enddo
6107         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6108           msglen=msglen2
6109             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6110 C Clear the contacts of the atom passed to the neighboring processor
6111         nn=num_cont_hb(iatel_s+1)
6112 cd      do i=1,nn
6113 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6114 cd      enddo
6115             num_cont_hb(iatel_s)=0
6116         endif
6117 cd      write (iout,*) 'Processor ',MyID,MyRank,
6118 cd   & ' is sending correlation contribution to processor',MyID-1,
6119 cd   & ' msglen=',msglen
6120 cd      write (*,*) 'Processor ',MyID,MyRank,
6121 cd   & ' is sending correlation contribution to processor',MyID-1,
6122 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6123         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6124 cd      write (iout,*) 'Processor ',MyID,
6125 cd   & ' has sent correlation contribution to processor',MyID-1,
6126 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6127 cd      write (*,*) 'Processor ',MyID,
6128 cd   & ' has sent correlation contribution to processor',MyID-1,
6129 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6130         msglen=msglen1
6131       endif ! (MyRank.gt.0)
6132       if (ldone) goto 30
6133       ldone=.true.
6134    20 continue
6135 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6136       if (MyRank.lt.fgProcs-1) then
6137 C Receive correlation contributions from the next processor
6138         msglen=msglen1
6139         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6140 cd      write (iout,*) 'Processor',MyID,
6141 cd   & ' is receiving correlation contribution from processor',MyID+1,
6142 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6143 cd      write (*,*) 'Processor',MyID,
6144 cd   & ' is receiving correlation contribution from processor',MyID+1,
6145 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6146         nbytes=-1
6147         do while (nbytes.le.0)
6148           call mp_probe(MyID+1,CorrelType,nbytes)
6149         enddo
6150 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6151         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6152 cd      write (iout,*) 'Processor',MyID,
6153 cd   & ' has received correlation contribution from processor',MyID+1,
6154 cd   & ' msglen=',msglen,' nbytes=',nbytes
6155 cd      write (iout,*) 'The received BUFFER array:'
6156 cd      do i=1,max_cont
6157 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6158 cd      enddo
6159         if (msglen.eq.msglen1) then
6160           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6161         else if (msglen.eq.msglen2)  then
6162           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6163           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6164         else
6165           write (iout,*)
6166      & 'ERROR!!!! message length changed while processing correlations.'
6167           write (*,*)
6168      & 'ERROR!!!! message length changed while processing correlations.'
6169           call mp_stopall(Error)
6170         endif ! msglen.eq.msglen1
6171       endif ! MyRank.lt.fgProcs-1
6172       if (ldone) goto 30
6173       ldone=.true.
6174       goto 10
6175    30 continue
6176 #endif
6177       if (lprn) then
6178         write (iout,'(a)') 'Contact function values:'
6179         do i=nnt,nct-2
6180           write (iout,'(2i3,50(1x,i2,f5.2))')
6181      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6182      &    j=1,num_cont_hb(i))
6183         enddo
6184       endif
6185       ecorr=0.0D0
6186       ecorr5=0.0d0
6187       ecorr6=0.0d0
6188 C Remove the loop below after debugging !!!
6189       do i=nnt,nct
6190         do j=1,3
6191           gradcorr(j,i)=0.0D0
6192           gradxorr(j,i)=0.0D0
6193         enddo
6194       enddo
6195 C Calculate the dipole-dipole interaction energies
6196       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6197       do i=iatel_s,iatel_e+1
6198         num_conti=num_cont_hb(i)
6199         do jj=1,num_conti
6200           j=jcont_hb(jj,i)
6201           call dipole(i,j,jj)
6202         enddo
6203       enddo
6204       endif
6205 C Calculate the local-electrostatic correlation terms
6206       do i=iatel_s,iatel_e+1
6207         i1=i+1
6208         num_conti=num_cont_hb(i)
6209         num_conti1=num_cont_hb(i+1)
6210         do jj=1,num_conti
6211           j=jcont_hb(jj,i)
6212           do kk=1,num_conti1
6213             j1=jcont_hb(kk,i1)
6214 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6215 c     &         ' jj=',jj,' kk=',kk
6216             if (j1.eq.j+1 .or. j1.eq.j-1) then
6217 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6218 C The system gains extra energy.
6219               n_corr=n_corr+1
6220               sqd1=dsqrt(d_cont(jj,i))
6221               sqd2=dsqrt(d_cont(kk,i1))
6222               sred_geom = sqd1*sqd2
6223               IF (sred_geom.lt.cutoff_corr) THEN
6224                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6225      &            ekont,fprimcont)
6226 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6227 c     &         ' jj=',jj,' kk=',kk
6228                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6229                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6230                 do l=1,3
6231                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6232                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6233                 enddo
6234                 n_corr1=n_corr1+1
6235 cd               write (iout,*) 'sred_geom=',sred_geom,
6236 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6237                 call calc_eello(i,j,i+1,j1,jj,kk)
6238                 if (wcorr4.gt.0.0d0)
6239      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6240                 if (wcorr5.gt.0.0d0)
6241      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6242 c                print *,"wcorr5",ecorr5
6243 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6244 cd                write(2,*)'ijkl',i,j,i+1,j1
6245                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6246      &               .or. wturn6.eq.0.0d0))then
6247 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6248                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6249 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6250 cd     &            'ecorr6=',ecorr6
6251 cd                write (iout,'(4e15.5)') sred_geom,
6252 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6253 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6254 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6255                 else if (wturn6.gt.0.0d0
6256      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6257 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6258                   eturn6=eturn6+eello_turn6(i,jj,kk)
6259 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6260                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6261                    eturn6=0.0d0
6262                    ecorr6=0.0d0
6263                 endif
6264
6265               ENDIF
6266 1111          continue
6267             else if (j1.eq.j) then
6268 C Contacts I-J and I-(J+1) occur simultaneously.
6269 C The system loses extra energy.
6270 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6271             endif
6272           enddo ! kk
6273           do kk=1,num_conti
6274             j1=jcont_hb(kk,i)
6275 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6276 c    &         ' jj=',jj,' kk=',kk
6277             if (j1.eq.j+1) then
6278 C Contacts I-J and (I+1)-J occur simultaneously.
6279 C The system loses extra energy.
6280 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6281             endif ! j1==j+1
6282           enddo ! kk
6283         enddo ! jj
6284       enddo ! i
6285       write (iout,*) "eturn6",eturn6,ecorr6
6286       return
6287       end
6288 c------------------------------------------------------------------------------
6289       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6290       implicit real*8 (a-h,o-z)
6291       include 'DIMENSIONS'
6292       include 'COMMON.IOUNITS'
6293       include 'COMMON.DERIV'
6294       include 'COMMON.INTERACT'
6295       include 'COMMON.CONTACTS'
6296       double precision gx(3),gx1(3)
6297       logical lprn
6298       lprn=.false.
6299       eij=facont_hb(jj,i)
6300       ekl=facont_hb(kk,k)
6301       ees0pij=ees0p(jj,i)
6302       ees0pkl=ees0p(kk,k)
6303       ees0mij=ees0m(jj,i)
6304       ees0mkl=ees0m(kk,k)
6305       ekont=eij*ekl
6306       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6307 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6308 C Following 4 lines for diagnostics.
6309 cd    ees0pkl=0.0D0
6310 cd    ees0pij=1.0D0
6311 cd    ees0mkl=0.0D0
6312 cd    ees0mij=1.0D0
6313 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6314 c    &   ' and',k,l
6315 c     write (iout,*)'Contacts have occurred for peptide groups',
6316 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6317 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6318 C Calculate the multi-body contribution to energy.
6319       ecorr=ecorr+ekont*ees
6320       if (calc_grad) then
6321 C Calculate multi-body contributions to the gradient.
6322       do ll=1,3
6323         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6324         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6325      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6326      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6327         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6328      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6329      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6330         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6331         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6332      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6333      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6334         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6335      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6336      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6337       enddo
6338       do m=i+1,j-1
6339         do ll=1,3
6340           gradcorr(ll,m)=gradcorr(ll,m)+
6341      &     ees*ekl*gacont_hbr(ll,jj,i)-
6342      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6343      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6344         enddo
6345       enddo
6346       do m=k+1,l-1
6347         do ll=1,3
6348           gradcorr(ll,m)=gradcorr(ll,m)+
6349      &     ees*eij*gacont_hbr(ll,kk,k)-
6350      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6351      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6352         enddo
6353       enddo
6354       endif
6355       ehbcorr=ekont*ees
6356       return
6357       end
6358 C---------------------------------------------------------------------------
6359       subroutine dipole(i,j,jj)
6360       implicit real*8 (a-h,o-z)
6361       include 'DIMENSIONS'
6362       include 'DIMENSIONS.ZSCOPT'
6363       include 'COMMON.IOUNITS'
6364       include 'COMMON.CHAIN'
6365       include 'COMMON.FFIELD'
6366       include 'COMMON.DERIV'
6367       include 'COMMON.INTERACT'
6368       include 'COMMON.CONTACTS'
6369       include 'COMMON.TORSION'
6370       include 'COMMON.VAR'
6371       include 'COMMON.GEO'
6372       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6373      &  auxmat(2,2)
6374       iti1 = itortyp(itype(i+1))
6375       if (j.lt.nres-1) then
6376         if (itype(j).le.ntyp) then
6377           itj1 = itortyp(itype(j+1))
6378         else
6379           itj=ntortyp+1
6380         endif
6381       else
6382         itj1=ntortyp+1
6383       endif
6384       do iii=1,2
6385         dipi(iii,1)=Ub2(iii,i)
6386         dipderi(iii)=Ub2der(iii,i)
6387         dipi(iii,2)=b1(iii,iti1)
6388         dipj(iii,1)=Ub2(iii,j)
6389         dipderj(iii)=Ub2der(iii,j)
6390         dipj(iii,2)=b1(iii,itj1)
6391       enddo
6392       kkk=0
6393       do iii=1,2
6394         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6395         do jjj=1,2
6396           kkk=kkk+1
6397           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6398         enddo
6399       enddo
6400       if (.not.calc_grad) return
6401       do kkk=1,5
6402         do lll=1,3
6403           mmm=0
6404           do iii=1,2
6405             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6406      &        auxvec(1))
6407             do jjj=1,2
6408               mmm=mmm+1
6409               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6410             enddo
6411           enddo
6412         enddo
6413       enddo
6414       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6415       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6416       do iii=1,2
6417         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6418       enddo
6419       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6420       do iii=1,2
6421         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6422       enddo
6423       return
6424       end
6425 C---------------------------------------------------------------------------
6426       subroutine calc_eello(i,j,k,l,jj,kk)
6427 C
6428 C This subroutine computes matrices and vectors needed to calculate
6429 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6430 C
6431       implicit real*8 (a-h,o-z)
6432       include 'DIMENSIONS'
6433       include 'DIMENSIONS.ZSCOPT'
6434       include 'COMMON.IOUNITS'
6435       include 'COMMON.CHAIN'
6436       include 'COMMON.DERIV'
6437       include 'COMMON.INTERACT'
6438       include 'COMMON.CONTACTS'
6439       include 'COMMON.TORSION'
6440       include 'COMMON.VAR'
6441       include 'COMMON.GEO'
6442       include 'COMMON.FFIELD'
6443       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6444      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6445       logical lprn
6446       common /kutas/ lprn
6447 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6448 cd     & ' jj=',jj,' kk=',kk
6449 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6450       do iii=1,2
6451         do jjj=1,2
6452           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6453           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6454         enddo
6455       enddo
6456       call transpose2(aa1(1,1),aa1t(1,1))
6457       call transpose2(aa2(1,1),aa2t(1,1))
6458       do kkk=1,5
6459         do lll=1,3
6460           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6461      &      aa1tder(1,1,lll,kkk))
6462           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6463      &      aa2tder(1,1,lll,kkk))
6464         enddo
6465       enddo
6466       if (l.eq.j+1) then
6467 C parallel orientation of the two CA-CA-CA frames.
6468         if (i.gt.1 .and. itype(i).le.ntyp) then
6469           iti=itortyp(itype(i))
6470         else
6471           iti=ntortyp+1
6472         endif
6473         itk1=itortyp(itype(k+1))
6474         itj=itortyp(itype(j))
6475         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6476           itl1=itortyp(itype(l+1))
6477         else
6478           itl1=ntortyp+1
6479         endif
6480 C A1 kernel(j+1) A2T
6481 cd        do iii=1,2
6482 cd          write (iout,'(3f10.5,5x,3f10.5)')
6483 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6484 cd        enddo
6485         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6486      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6487      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6488 C Following matrices are needed only for 6-th order cumulants
6489         IF (wcorr6.gt.0.0d0) THEN
6490         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6491      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6492      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6493         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6494      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6495      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6496      &   ADtEAderx(1,1,1,1,1,1))
6497         lprn=.false.
6498         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6499      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6500      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6501      &   ADtEA1derx(1,1,1,1,1,1))
6502         ENDIF
6503 C End 6-th order cumulants
6504 cd        lprn=.false.
6505 cd        if (lprn) then
6506 cd        write (2,*) 'In calc_eello6'
6507 cd        do iii=1,2
6508 cd          write (2,*) 'iii=',iii
6509 cd          do kkk=1,5
6510 cd            write (2,*) 'kkk=',kkk
6511 cd            do jjj=1,2
6512 cd              write (2,'(3(2f10.5),5x)')
6513 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6514 cd            enddo
6515 cd          enddo
6516 cd        enddo
6517 cd        endif
6518         call transpose2(EUgder(1,1,k),auxmat(1,1))
6519         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6520         call transpose2(EUg(1,1,k),auxmat(1,1))
6521         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6522         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6523         do iii=1,2
6524           do kkk=1,5
6525             do lll=1,3
6526               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6527      &          EAEAderx(1,1,lll,kkk,iii,1))
6528             enddo
6529           enddo
6530         enddo
6531 C A1T kernel(i+1) A2
6532         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6533      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6534      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6535 C Following matrices are needed only for 6-th order cumulants
6536         IF (wcorr6.gt.0.0d0) THEN
6537         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6538      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6539      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6540         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6541      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6542      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6543      &   ADtEAderx(1,1,1,1,1,2))
6544         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6545      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6546      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6547      &   ADtEA1derx(1,1,1,1,1,2))
6548         ENDIF
6549 C End 6-th order cumulants
6550         call transpose2(EUgder(1,1,l),auxmat(1,1))
6551         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6552         call transpose2(EUg(1,1,l),auxmat(1,1))
6553         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6554         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6555         do iii=1,2
6556           do kkk=1,5
6557             do lll=1,3
6558               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6559      &          EAEAderx(1,1,lll,kkk,iii,2))
6560             enddo
6561           enddo
6562         enddo
6563 C AEAb1 and AEAb2
6564 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6565 C They are needed only when the fifth- or the sixth-order cumulants are
6566 C indluded.
6567         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6568         call transpose2(AEA(1,1,1),auxmat(1,1))
6569         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6570         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6571         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6572         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6573         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6574         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6575         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6576         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6577         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6578         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6579         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6580         call transpose2(AEA(1,1,2),auxmat(1,1))
6581         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6582         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6583         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6584         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6585         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6586         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6587         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6588         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6589         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6590         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6591         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6592 C Calculate the Cartesian derivatives of the vectors.
6593         do iii=1,2
6594           do kkk=1,5
6595             do lll=1,3
6596               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6597               call matvec2(auxmat(1,1),b1(1,iti),
6598      &          AEAb1derx(1,lll,kkk,iii,1,1))
6599               call matvec2(auxmat(1,1),Ub2(1,i),
6600      &          AEAb2derx(1,lll,kkk,iii,1,1))
6601               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6602      &          AEAb1derx(1,lll,kkk,iii,2,1))
6603               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6604      &          AEAb2derx(1,lll,kkk,iii,2,1))
6605               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6606               call matvec2(auxmat(1,1),b1(1,itj),
6607      &          AEAb1derx(1,lll,kkk,iii,1,2))
6608               call matvec2(auxmat(1,1),Ub2(1,j),
6609      &          AEAb2derx(1,lll,kkk,iii,1,2))
6610               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6611      &          AEAb1derx(1,lll,kkk,iii,2,2))
6612               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6613      &          AEAb2derx(1,lll,kkk,iii,2,2))
6614             enddo
6615           enddo
6616         enddo
6617         ENDIF
6618 C End vectors
6619       else
6620 C Antiparallel orientation of the two CA-CA-CA frames.
6621         if (i.gt.1 .and. itype(i).le.ntyp) then
6622           iti=itortyp(itype(i))
6623         else
6624           iti=ntortyp+1
6625         endif
6626         itk1=itortyp(itype(k+1))
6627         itl=itortyp(itype(l))
6628         itj=itortyp(itype(j))
6629         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6630           itj1=itortyp(itype(j+1))
6631         else
6632           itj1=ntortyp+1
6633         endif
6634 C A2 kernel(j-1)T A1T
6635         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6636      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6637      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6638 C Following matrices are needed only for 6-th order cumulants
6639         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6640      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6641         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6642      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6643      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6644         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6645      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6646      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6647      &   ADtEAderx(1,1,1,1,1,1))
6648         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6649      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6650      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6651      &   ADtEA1derx(1,1,1,1,1,1))
6652         ENDIF
6653 C End 6-th order cumulants
6654         call transpose2(EUgder(1,1,k),auxmat(1,1))
6655         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6656         call transpose2(EUg(1,1,k),auxmat(1,1))
6657         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6658         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6659         do iii=1,2
6660           do kkk=1,5
6661             do lll=1,3
6662               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6663      &          EAEAderx(1,1,lll,kkk,iii,1))
6664             enddo
6665           enddo
6666         enddo
6667 C A2T kernel(i+1)T A1
6668         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6669      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6670      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6671 C Following matrices are needed only for 6-th order cumulants
6672         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6673      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6674         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6675      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6676      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6677         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6678      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6679      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6680      &   ADtEAderx(1,1,1,1,1,2))
6681         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6682      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6683      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6684      &   ADtEA1derx(1,1,1,1,1,2))
6685         ENDIF
6686 C End 6-th order cumulants
6687         call transpose2(EUgder(1,1,j),auxmat(1,1))
6688         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6689         call transpose2(EUg(1,1,j),auxmat(1,1))
6690         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6691         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6692         do iii=1,2
6693           do kkk=1,5
6694             do lll=1,3
6695               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6696      &          EAEAderx(1,1,lll,kkk,iii,2))
6697             enddo
6698           enddo
6699         enddo
6700 C AEAb1 and AEAb2
6701 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6702 C They are needed only when the fifth- or the sixth-order cumulants are
6703 C indluded.
6704         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6705      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6706         call transpose2(AEA(1,1,1),auxmat(1,1))
6707         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6708         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6709         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6710         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6711         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6712         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6713         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6714         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6715         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6716         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6717         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6718         call transpose2(AEA(1,1,2),auxmat(1,1))
6719         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6720         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6721         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6722         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6723         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6724         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6725         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6726         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6727         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6728         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6729         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6730 C Calculate the Cartesian derivatives of the vectors.
6731         do iii=1,2
6732           do kkk=1,5
6733             do lll=1,3
6734               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6735               call matvec2(auxmat(1,1),b1(1,iti),
6736      &          AEAb1derx(1,lll,kkk,iii,1,1))
6737               call matvec2(auxmat(1,1),Ub2(1,i),
6738      &          AEAb2derx(1,lll,kkk,iii,1,1))
6739               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6740      &          AEAb1derx(1,lll,kkk,iii,2,1))
6741               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6742      &          AEAb2derx(1,lll,kkk,iii,2,1))
6743               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6744               call matvec2(auxmat(1,1),b1(1,itl),
6745      &          AEAb1derx(1,lll,kkk,iii,1,2))
6746               call matvec2(auxmat(1,1),Ub2(1,l),
6747      &          AEAb2derx(1,lll,kkk,iii,1,2))
6748               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6749      &          AEAb1derx(1,lll,kkk,iii,2,2))
6750               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6751      &          AEAb2derx(1,lll,kkk,iii,2,2))
6752             enddo
6753           enddo
6754         enddo
6755         ENDIF
6756 C End vectors
6757       endif
6758       return
6759       end
6760 C---------------------------------------------------------------------------
6761       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6762      &  KK,KKderg,AKA,AKAderg,AKAderx)
6763       implicit none
6764       integer nderg
6765       logical transp
6766       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6767      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6768      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6769       integer iii,kkk,lll
6770       integer jjj,mmm
6771       logical lprn
6772       common /kutas/ lprn
6773       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6774       do iii=1,nderg
6775         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6776      &    AKAderg(1,1,iii))
6777       enddo
6778 cd      if (lprn) write (2,*) 'In kernel'
6779       do kkk=1,5
6780 cd        if (lprn) write (2,*) 'kkk=',kkk
6781         do lll=1,3
6782           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6783      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6784 cd          if (lprn) then
6785 cd            write (2,*) 'lll=',lll
6786 cd            write (2,*) 'iii=1'
6787 cd            do jjj=1,2
6788 cd              write (2,'(3(2f10.5),5x)')
6789 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6790 cd            enddo
6791 cd          endif
6792           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6793      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6794 cd          if (lprn) then
6795 cd            write (2,*) 'lll=',lll
6796 cd            write (2,*) 'iii=2'
6797 cd            do jjj=1,2
6798 cd              write (2,'(3(2f10.5),5x)')
6799 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6800 cd            enddo
6801 cd          endif
6802         enddo
6803       enddo
6804       return
6805       end
6806 C---------------------------------------------------------------------------
6807       double precision function eello4(i,j,k,l,jj,kk)
6808       implicit real*8 (a-h,o-z)
6809       include 'DIMENSIONS'
6810       include 'DIMENSIONS.ZSCOPT'
6811       include 'COMMON.IOUNITS'
6812       include 'COMMON.CHAIN'
6813       include 'COMMON.DERIV'
6814       include 'COMMON.INTERACT'
6815       include 'COMMON.CONTACTS'
6816       include 'COMMON.TORSION'
6817       include 'COMMON.VAR'
6818       include 'COMMON.GEO'
6819       double precision pizda(2,2),ggg1(3),ggg2(3)
6820 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6821 cd        eello4=0.0d0
6822 cd        return
6823 cd      endif
6824 cd      print *,'eello4:',i,j,k,l,jj,kk
6825 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6826 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6827 cold      eij=facont_hb(jj,i)
6828 cold      ekl=facont_hb(kk,k)
6829 cold      ekont=eij*ekl
6830       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6831       if (calc_grad) then
6832 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6833       gcorr_loc(k-1)=gcorr_loc(k-1)
6834      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6835       if (l.eq.j+1) then
6836         gcorr_loc(l-1)=gcorr_loc(l-1)
6837      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6838       else
6839         gcorr_loc(j-1)=gcorr_loc(j-1)
6840      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6841       endif
6842       do iii=1,2
6843         do kkk=1,5
6844           do lll=1,3
6845             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6846      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6847 cd            derx(lll,kkk,iii)=0.0d0
6848           enddo
6849         enddo
6850       enddo
6851 cd      gcorr_loc(l-1)=0.0d0
6852 cd      gcorr_loc(j-1)=0.0d0
6853 cd      gcorr_loc(k-1)=0.0d0
6854 cd      eel4=1.0d0
6855 cd      write (iout,*)'Contacts have occurred for peptide groups',
6856 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6857 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6858       if (j.lt.nres-1) then
6859         j1=j+1
6860         j2=j-1
6861       else
6862         j1=j-1
6863         j2=j-2
6864       endif
6865       if (l.lt.nres-1) then
6866         l1=l+1
6867         l2=l-1
6868       else
6869         l1=l-1
6870         l2=l-2
6871       endif
6872       do ll=1,3
6873 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6874         ggg1(ll)=eel4*g_contij(ll,1)
6875         ggg2(ll)=eel4*g_contij(ll,2)
6876         ghalf=0.5d0*ggg1(ll)
6877 cd        ghalf=0.0d0
6878         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6879         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6880         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6881         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6882 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6883         ghalf=0.5d0*ggg2(ll)
6884 cd        ghalf=0.0d0
6885         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6886         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6887         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6888         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6889       enddo
6890 cd      goto 1112
6891       do m=i+1,j-1
6892         do ll=1,3
6893 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6894           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6895         enddo
6896       enddo
6897       do m=k+1,l-1
6898         do ll=1,3
6899 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6900           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6901         enddo
6902       enddo
6903 1112  continue
6904       do m=i+2,j2
6905         do ll=1,3
6906           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6907         enddo
6908       enddo
6909       do m=k+2,l2
6910         do ll=1,3
6911           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6912         enddo
6913       enddo
6914 cd      do iii=1,nres-3
6915 cd        write (2,*) iii,gcorr_loc(iii)
6916 cd      enddo
6917       endif
6918       eello4=ekont*eel4
6919 cd      write (2,*) 'ekont',ekont
6920 cd      write (iout,*) 'eello4',ekont*eel4
6921       return
6922       end
6923 C---------------------------------------------------------------------------
6924       double precision function eello5(i,j,k,l,jj,kk)
6925       implicit real*8 (a-h,o-z)
6926       include 'DIMENSIONS'
6927       include 'DIMENSIONS.ZSCOPT'
6928       include 'COMMON.IOUNITS'
6929       include 'COMMON.CHAIN'
6930       include 'COMMON.DERIV'
6931       include 'COMMON.INTERACT'
6932       include 'COMMON.CONTACTS'
6933       include 'COMMON.TORSION'
6934       include 'COMMON.VAR'
6935       include 'COMMON.GEO'
6936       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6937       double precision ggg1(3),ggg2(3)
6938 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6939 C                                                                              C
6940 C                            Parallel chains                                   C
6941 C                                                                              C
6942 C          o             o                   o             o                   C
6943 C         /l\           / \             \   / \           / \   /              C
6944 C        /   \         /   \             \ /   \         /   \ /               C
6945 C       j| o |l1       | o |              o| o |         | o |o                C
6946 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6947 C      \i/   \         /   \ /             /   \         /   \                 C
6948 C       o    k1             o                                                  C
6949 C         (I)          (II)                (III)          (IV)                 C
6950 C                                                                              C
6951 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6952 C                                                                              C
6953 C                            Antiparallel chains                               C
6954 C                                                                              C
6955 C          o             o                   o             o                   C
6956 C         /j\           / \             \   / \           / \   /              C
6957 C        /   \         /   \             \ /   \         /   \ /               C
6958 C      j1| o |l        | o |              o| o |         | o |o                C
6959 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6960 C      \i/   \         /   \ /             /   \         /   \                 C
6961 C       o     k1            o                                                  C
6962 C         (I)          (II)                (III)          (IV)                 C
6963 C                                                                              C
6964 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6965 C                                                                              C
6966 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6967 C                                                                              C
6968 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6969 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6970 cd        eello5=0.0d0
6971 cd        return
6972 cd      endif
6973 cd      write (iout,*)
6974 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6975 cd     &   ' and',k,l
6976       itk=itortyp(itype(k))
6977       itl=itortyp(itype(l))
6978       itj=itortyp(itype(j))
6979       eello5_1=0.0d0
6980       eello5_2=0.0d0
6981       eello5_3=0.0d0
6982       eello5_4=0.0d0
6983 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6984 cd     &   eel5_3_num,eel5_4_num)
6985       do iii=1,2
6986         do kkk=1,5
6987           do lll=1,3
6988             derx(lll,kkk,iii)=0.0d0
6989           enddo
6990         enddo
6991       enddo
6992 cd      eij=facont_hb(jj,i)
6993 cd      ekl=facont_hb(kk,k)
6994 cd      ekont=eij*ekl
6995 cd      write (iout,*)'Contacts have occurred for peptide groups',
6996 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6997 cd      goto 1111
6998 C Contribution from the graph I.
6999 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7000 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7001       call transpose2(EUg(1,1,k),auxmat(1,1))
7002       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7003       vv(1)=pizda(1,1)-pizda(2,2)
7004       vv(2)=pizda(1,2)+pizda(2,1)
7005       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7006      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7007       if (calc_grad) then
7008 C Explicit gradient in virtual-dihedral angles.
7009       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7010      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7011      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7012       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7013       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7014       vv(1)=pizda(1,1)-pizda(2,2)
7015       vv(2)=pizda(1,2)+pizda(2,1)
7016       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7017      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7018      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7019       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7020       vv(1)=pizda(1,1)-pizda(2,2)
7021       vv(2)=pizda(1,2)+pizda(2,1)
7022       if (l.eq.j+1) then
7023         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7024      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7025      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7026       else
7027         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7028      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7029      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7030       endif
7031 C Cartesian gradient
7032       do iii=1,2
7033         do kkk=1,5
7034           do lll=1,3
7035             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7036      &        pizda(1,1))
7037             vv(1)=pizda(1,1)-pizda(2,2)
7038             vv(2)=pizda(1,2)+pizda(2,1)
7039             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7040      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7041      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7042           enddo
7043         enddo
7044       enddo
7045 c      goto 1112
7046       endif
7047 c1111  continue
7048 C Contribution from graph II
7049       call transpose2(EE(1,1,itk),auxmat(1,1))
7050       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7051       vv(1)=pizda(1,1)+pizda(2,2)
7052       vv(2)=pizda(2,1)-pizda(1,2)
7053       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7054      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7055       if (calc_grad) then
7056 C Explicit gradient in virtual-dihedral angles.
7057       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7058      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7059       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7060       vv(1)=pizda(1,1)+pizda(2,2)
7061       vv(2)=pizda(2,1)-pizda(1,2)
7062       if (l.eq.j+1) then
7063         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7064      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7065      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7066       else
7067         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7068      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7069      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7070       endif
7071 C Cartesian gradient
7072       do iii=1,2
7073         do kkk=1,5
7074           do lll=1,3
7075             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7076      &        pizda(1,1))
7077             vv(1)=pizda(1,1)+pizda(2,2)
7078             vv(2)=pizda(2,1)-pizda(1,2)
7079             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7080      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7081      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7082           enddo
7083         enddo
7084       enddo
7085 cd      goto 1112
7086       endif
7087 cd1111  continue
7088       if (l.eq.j+1) then
7089 cd        goto 1110
7090 C Parallel orientation
7091 C Contribution from graph III
7092         call transpose2(EUg(1,1,l),auxmat(1,1))
7093         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7094         vv(1)=pizda(1,1)-pizda(2,2)
7095         vv(2)=pizda(1,2)+pizda(2,1)
7096         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7097      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7098         if (calc_grad) then
7099 C Explicit gradient in virtual-dihedral angles.
7100         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7101      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7102      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7103         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7104         vv(1)=pizda(1,1)-pizda(2,2)
7105         vv(2)=pizda(1,2)+pizda(2,1)
7106         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7107      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7108      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7109         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7110         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7111         vv(1)=pizda(1,1)-pizda(2,2)
7112         vv(2)=pizda(1,2)+pizda(2,1)
7113         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7114      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7115      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7116 C Cartesian gradient
7117         do iii=1,2
7118           do kkk=1,5
7119             do lll=1,3
7120               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7121      &          pizda(1,1))
7122               vv(1)=pizda(1,1)-pizda(2,2)
7123               vv(2)=pizda(1,2)+pizda(2,1)
7124               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7125      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7126      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7127             enddo
7128           enddo
7129         enddo
7130 cd        goto 1112
7131         endif
7132 C Contribution from graph IV
7133 cd1110    continue
7134         call transpose2(EE(1,1,itl),auxmat(1,1))
7135         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7136         vv(1)=pizda(1,1)+pizda(2,2)
7137         vv(2)=pizda(2,1)-pizda(1,2)
7138         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7139      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7140         if (calc_grad) then
7141 C Explicit gradient in virtual-dihedral angles.
7142         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7143      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7144         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7145         vv(1)=pizda(1,1)+pizda(2,2)
7146         vv(2)=pizda(2,1)-pizda(1,2)
7147         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7148      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7149      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7150 C Cartesian gradient
7151         do iii=1,2
7152           do kkk=1,5
7153             do lll=1,3
7154               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7155      &          pizda(1,1))
7156               vv(1)=pizda(1,1)+pizda(2,2)
7157               vv(2)=pizda(2,1)-pizda(1,2)
7158               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7159      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7160      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7161             enddo
7162           enddo
7163         enddo
7164         endif
7165       else
7166 C Antiparallel orientation
7167 C Contribution from graph III
7168 c        goto 1110
7169         call transpose2(EUg(1,1,j),auxmat(1,1))
7170         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7171         vv(1)=pizda(1,1)-pizda(2,2)
7172         vv(2)=pizda(1,2)+pizda(2,1)
7173         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7174      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7175         if (calc_grad) then
7176 C Explicit gradient in virtual-dihedral angles.
7177         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7178      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7179      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7180         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7181         vv(1)=pizda(1,1)-pizda(2,2)
7182         vv(2)=pizda(1,2)+pizda(2,1)
7183         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7184      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7185      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7186         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7187         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7188         vv(1)=pizda(1,1)-pizda(2,2)
7189         vv(2)=pizda(1,2)+pizda(2,1)
7190         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7191      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7192      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7193 C Cartesian gradient
7194         do iii=1,2
7195           do kkk=1,5
7196             do lll=1,3
7197               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7198      &          pizda(1,1))
7199               vv(1)=pizda(1,1)-pizda(2,2)
7200               vv(2)=pizda(1,2)+pizda(2,1)
7201               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7202      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7203      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7204             enddo
7205           enddo
7206         enddo
7207 cd        goto 1112
7208         endif
7209 C Contribution from graph IV
7210 1110    continue
7211         call transpose2(EE(1,1,itj),auxmat(1,1))
7212         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7213         vv(1)=pizda(1,1)+pizda(2,2)
7214         vv(2)=pizda(2,1)-pizda(1,2)
7215         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7216      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7217         if (calc_grad) then
7218 C Explicit gradient in virtual-dihedral angles.
7219         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7220      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7221         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7222         vv(1)=pizda(1,1)+pizda(2,2)
7223         vv(2)=pizda(2,1)-pizda(1,2)
7224         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7225      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7226      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7227 C Cartesian gradient
7228         do iii=1,2
7229           do kkk=1,5
7230             do lll=1,3
7231               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7232      &          pizda(1,1))
7233               vv(1)=pizda(1,1)+pizda(2,2)
7234               vv(2)=pizda(2,1)-pizda(1,2)
7235               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7236      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7237      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7238             enddo
7239           enddo
7240         enddo
7241       endif
7242       endif
7243 1112  continue
7244       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7245 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7246 cd        write (2,*) 'ijkl',i,j,k,l
7247 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7248 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7249 cd      endif
7250 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7251 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7252 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7253 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7254       if (calc_grad) then
7255       if (j.lt.nres-1) then
7256         j1=j+1
7257         j2=j-1
7258       else
7259         j1=j-1
7260         j2=j-2
7261       endif
7262       if (l.lt.nres-1) then
7263         l1=l+1
7264         l2=l-1
7265       else
7266         l1=l-1
7267         l2=l-2
7268       endif
7269 cd      eij=1.0d0
7270 cd      ekl=1.0d0
7271 cd      ekont=1.0d0
7272 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7273       do ll=1,3
7274         ggg1(ll)=eel5*g_contij(ll,1)
7275         ggg2(ll)=eel5*g_contij(ll,2)
7276 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7277         ghalf=0.5d0*ggg1(ll)
7278 cd        ghalf=0.0d0
7279         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7280         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7281         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7282         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7283 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7284         ghalf=0.5d0*ggg2(ll)
7285 cd        ghalf=0.0d0
7286         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7287         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7288         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7289         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7290       enddo
7291 cd      goto 1112
7292       do m=i+1,j-1
7293         do ll=1,3
7294 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7295           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7296         enddo
7297       enddo
7298       do m=k+1,l-1
7299         do ll=1,3
7300 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7301           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7302         enddo
7303       enddo
7304 c1112  continue
7305       do m=i+2,j2
7306         do ll=1,3
7307           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7308         enddo
7309       enddo
7310       do m=k+2,l2
7311         do ll=1,3
7312           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7313         enddo
7314       enddo
7315 cd      do iii=1,nres-3
7316 cd        write (2,*) iii,g_corr5_loc(iii)
7317 cd      enddo
7318       endif
7319       eello5=ekont*eel5
7320 cd      write (2,*) 'ekont',ekont
7321 cd      write (iout,*) 'eello5',ekont*eel5
7322       return
7323       end
7324 c--------------------------------------------------------------------------
7325       double precision function eello6(i,j,k,l,jj,kk)
7326       implicit real*8 (a-h,o-z)
7327       include 'DIMENSIONS'
7328       include 'DIMENSIONS.ZSCOPT'
7329       include 'COMMON.IOUNITS'
7330       include 'COMMON.CHAIN'
7331       include 'COMMON.DERIV'
7332       include 'COMMON.INTERACT'
7333       include 'COMMON.CONTACTS'
7334       include 'COMMON.TORSION'
7335       include 'COMMON.VAR'
7336       include 'COMMON.GEO'
7337       include 'COMMON.FFIELD'
7338       double precision ggg1(3),ggg2(3)
7339 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7340 cd        eello6=0.0d0
7341 cd        return
7342 cd      endif
7343 cd      write (iout,*)
7344 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7345 cd     &   ' and',k,l
7346       eello6_1=0.0d0
7347       eello6_2=0.0d0
7348       eello6_3=0.0d0
7349       eello6_4=0.0d0
7350       eello6_5=0.0d0
7351       eello6_6=0.0d0
7352 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7353 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7354       do iii=1,2
7355         do kkk=1,5
7356           do lll=1,3
7357             derx(lll,kkk,iii)=0.0d0
7358           enddo
7359         enddo
7360       enddo
7361 cd      eij=facont_hb(jj,i)
7362 cd      ekl=facont_hb(kk,k)
7363 cd      ekont=eij*ekl
7364 cd      eij=1.0d0
7365 cd      ekl=1.0d0
7366 cd      ekont=1.0d0
7367       if (l.eq.j+1) then
7368         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7369         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7370         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7371         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7372         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7373         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7374       else
7375         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7376         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7377         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7378         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7379         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7380           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7381         else
7382           eello6_5=0.0d0
7383         endif
7384         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7385       endif
7386 C If turn contributions are considered, they will be handled separately.
7387       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7388 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7389 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7390 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7391 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7392 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7393 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7394 cd      goto 1112
7395       if (calc_grad) then
7396       if (j.lt.nres-1) then
7397         j1=j+1
7398         j2=j-1
7399       else
7400         j1=j-1
7401         j2=j-2
7402       endif
7403       if (l.lt.nres-1) then
7404         l1=l+1
7405         l2=l-1
7406       else
7407         l1=l-1
7408         l2=l-2
7409       endif
7410       do ll=1,3
7411         ggg1(ll)=eel6*g_contij(ll,1)
7412         ggg2(ll)=eel6*g_contij(ll,2)
7413 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7414         ghalf=0.5d0*ggg1(ll)
7415 cd        ghalf=0.0d0
7416         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7417         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7418         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7419         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7420         ghalf=0.5d0*ggg2(ll)
7421 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7422 cd        ghalf=0.0d0
7423         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7424         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7425         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7426         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7427       enddo
7428 cd      goto 1112
7429       do m=i+1,j-1
7430         do ll=1,3
7431 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7432           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7433         enddo
7434       enddo
7435       do m=k+1,l-1
7436         do ll=1,3
7437 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7438           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7439         enddo
7440       enddo
7441 1112  continue
7442       do m=i+2,j2
7443         do ll=1,3
7444           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7445         enddo
7446       enddo
7447       do m=k+2,l2
7448         do ll=1,3
7449           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7450         enddo
7451       enddo
7452 cd      do iii=1,nres-3
7453 cd        write (2,*) iii,g_corr6_loc(iii)
7454 cd      enddo
7455       endif
7456       eello6=ekont*eel6
7457 cd      write (2,*) 'ekont',ekont
7458 cd      write (iout,*) 'eello6',ekont*eel6
7459       return
7460       end
7461 c--------------------------------------------------------------------------
7462       double precision function eello6_graph1(i,j,k,l,imat,swap)
7463       implicit real*8 (a-h,o-z)
7464       include 'DIMENSIONS'
7465       include 'DIMENSIONS.ZSCOPT'
7466       include 'COMMON.IOUNITS'
7467       include 'COMMON.CHAIN'
7468       include 'COMMON.DERIV'
7469       include 'COMMON.INTERACT'
7470       include 'COMMON.CONTACTS'
7471       include 'COMMON.TORSION'
7472       include 'COMMON.VAR'
7473       include 'COMMON.GEO'
7474       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7475       logical swap
7476       logical lprn
7477       common /kutas/ lprn
7478 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7479 C                                                                              C
7480 C      Parallel       Antiparallel                                             C
7481 C                                                                              C
7482 C          o             o                                                     C
7483 C         /l\           /j\                                                    C
7484 C        /   \         /   \                                                   C
7485 C       /| o |         | o |\                                                  C
7486 C     \ j|/k\|  /   \  |/k\|l /                                                C
7487 C      \ /   \ /     \ /   \ /                                                 C
7488 C       o     o       o     o                                                  C
7489 C       i             i                                                        C
7490 C                                                                              C
7491 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7492       itk=itortyp(itype(k))
7493       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7494       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7495       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7496       call transpose2(EUgC(1,1,k),auxmat(1,1))
7497       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7498       vv1(1)=pizda1(1,1)-pizda1(2,2)
7499       vv1(2)=pizda1(1,2)+pizda1(2,1)
7500       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7501       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7502       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7503       s5=scalar2(vv(1),Dtobr2(1,i))
7504 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7505       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7506       if (.not. calc_grad) return
7507       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7508      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7509      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7510      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7511      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7512      & +scalar2(vv(1),Dtobr2der(1,i)))
7513       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7514       vv1(1)=pizda1(1,1)-pizda1(2,2)
7515       vv1(2)=pizda1(1,2)+pizda1(2,1)
7516       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7517       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7518       if (l.eq.j+1) then
7519         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7520      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7521      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7522      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7523      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7524       else
7525         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7526      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7527      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7528      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7529      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7530       endif
7531       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7532       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7533       vv1(1)=pizda1(1,1)-pizda1(2,2)
7534       vv1(2)=pizda1(1,2)+pizda1(2,1)
7535       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7536      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7537      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7538      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7539       do iii=1,2
7540         if (swap) then
7541           ind=3-iii
7542         else
7543           ind=iii
7544         endif
7545         do kkk=1,5
7546           do lll=1,3
7547             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7548             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7549             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7550             call transpose2(EUgC(1,1,k),auxmat(1,1))
7551             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7552      &        pizda1(1,1))
7553             vv1(1)=pizda1(1,1)-pizda1(2,2)
7554             vv1(2)=pizda1(1,2)+pizda1(2,1)
7555             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7556             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7557      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7558             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7559      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7560             s5=scalar2(vv(1),Dtobr2(1,i))
7561             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7562           enddo
7563         enddo
7564       enddo
7565       return
7566       end
7567 c----------------------------------------------------------------------------
7568       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7569       implicit real*8 (a-h,o-z)
7570       include 'DIMENSIONS'
7571       include 'DIMENSIONS.ZSCOPT'
7572       include 'COMMON.IOUNITS'
7573       include 'COMMON.CHAIN'
7574       include 'COMMON.DERIV'
7575       include 'COMMON.INTERACT'
7576       include 'COMMON.CONTACTS'
7577       include 'COMMON.TORSION'
7578       include 'COMMON.VAR'
7579       include 'COMMON.GEO'
7580       logical swap
7581       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7582      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7583       logical lprn
7584       common /kutas/ lprn
7585 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7586 C                                                                              C
7587 C      Parallel       Antiparallel                                             C
7588 C                                                                              C
7589 C          o             o                                                     C
7590 C     \   /l\           /j\   /                                                C
7591 C      \ /   \         /   \ /                                                 C
7592 C       o| o |         | o |o                                                  C
7593 C     \ j|/k\|      \  |/k\|l                                                  C
7594 C      \ /   \       \ /   \                                                   C
7595 C       o             o                                                        C
7596 C       i             i                                                        C
7597 C                                                                              C
7598 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7599 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7600 C AL 7/4/01 s1 would occur in the sixth-order moment,
7601 C           but not in a cluster cumulant
7602 #ifdef MOMENT
7603       s1=dip(1,jj,i)*dip(1,kk,k)
7604 #endif
7605       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7606       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7607       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7608       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7609       call transpose2(EUg(1,1,k),auxmat(1,1))
7610       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7611       vv(1)=pizda(1,1)-pizda(2,2)
7612       vv(2)=pizda(1,2)+pizda(2,1)
7613       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7614 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7615 #ifdef MOMENT
7616       eello6_graph2=-(s1+s2+s3+s4)
7617 #else
7618       eello6_graph2=-(s2+s3+s4)
7619 #endif
7620 c      eello6_graph2=-s3
7621       if (.not. calc_grad) return
7622 C Derivatives in gamma(i-1)
7623       if (i.gt.1) then
7624 #ifdef MOMENT
7625         s1=dipderg(1,jj,i)*dip(1,kk,k)
7626 #endif
7627         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7628         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7629         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7630         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7631 #ifdef MOMENT
7632         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7633 #else
7634         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7635 #endif
7636 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7637       endif
7638 C Derivatives in gamma(k-1)
7639 #ifdef MOMENT
7640       s1=dip(1,jj,i)*dipderg(1,kk,k)
7641 #endif
7642       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7643       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7644       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7645       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7646       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7647       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7648       vv(1)=pizda(1,1)-pizda(2,2)
7649       vv(2)=pizda(1,2)+pizda(2,1)
7650       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7651 #ifdef MOMENT
7652       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7653 #else
7654       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7655 #endif
7656 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7657 C Derivatives in gamma(j-1) or gamma(l-1)
7658       if (j.gt.1) then
7659 #ifdef MOMENT
7660         s1=dipderg(3,jj,i)*dip(1,kk,k)
7661 #endif
7662         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7663         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7664         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7665         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7666         vv(1)=pizda(1,1)-pizda(2,2)
7667         vv(2)=pizda(1,2)+pizda(2,1)
7668         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7669 #ifdef MOMENT
7670         if (swap) then
7671           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7672         else
7673           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7674         endif
7675 #endif
7676         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7677 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7678       endif
7679 C Derivatives in gamma(l-1) or gamma(j-1)
7680       if (l.gt.1) then
7681 #ifdef MOMENT
7682         s1=dip(1,jj,i)*dipderg(3,kk,k)
7683 #endif
7684         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7685         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7686         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7687         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7688         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7689         vv(1)=pizda(1,1)-pizda(2,2)
7690         vv(2)=pizda(1,2)+pizda(2,1)
7691         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7692 #ifdef MOMENT
7693         if (swap) then
7694           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7695         else
7696           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7697         endif
7698 #endif
7699         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7700 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7701       endif
7702 C Cartesian derivatives.
7703       if (lprn) then
7704         write (2,*) 'In eello6_graph2'
7705         do iii=1,2
7706           write (2,*) 'iii=',iii
7707           do kkk=1,5
7708             write (2,*) 'kkk=',kkk
7709             do jjj=1,2
7710               write (2,'(3(2f10.5),5x)')
7711      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7712             enddo
7713           enddo
7714         enddo
7715       endif
7716       do iii=1,2
7717         do kkk=1,5
7718           do lll=1,3
7719 #ifdef MOMENT
7720             if (iii.eq.1) then
7721               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7722             else
7723               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7724             endif
7725 #endif
7726             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7727      &        auxvec(1))
7728             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7729             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7730      &        auxvec(1))
7731             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7732             call transpose2(EUg(1,1,k),auxmat(1,1))
7733             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7734      &        pizda(1,1))
7735             vv(1)=pizda(1,1)-pizda(2,2)
7736             vv(2)=pizda(1,2)+pizda(2,1)
7737             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7738 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7739 #ifdef MOMENT
7740             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7741 #else
7742             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7743 #endif
7744             if (swap) then
7745               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7746             else
7747               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7748             endif
7749           enddo
7750         enddo
7751       enddo
7752       return
7753       end
7754 c----------------------------------------------------------------------------
7755       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7756       implicit real*8 (a-h,o-z)
7757       include 'DIMENSIONS'
7758       include 'DIMENSIONS.ZSCOPT'
7759       include 'COMMON.IOUNITS'
7760       include 'COMMON.CHAIN'
7761       include 'COMMON.DERIV'
7762       include 'COMMON.INTERACT'
7763       include 'COMMON.CONTACTS'
7764       include 'COMMON.TORSION'
7765       include 'COMMON.VAR'
7766       include 'COMMON.GEO'
7767       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7768       logical swap
7769 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7770 C                                                                              C
7771 C      Parallel       Antiparallel                                             C
7772 C                                                                              C
7773 C          o             o                                                     C
7774 C         /l\   /   \   /j\                                                    C
7775 C        /   \ /     \ /   \                                                   C
7776 C       /| o |o       o| o |\                                                  C
7777 C       j|/k\|  /      |/k\|l /                                                C
7778 C        /   \ /       /   \ /                                                 C
7779 C       /     o       /     o                                                  C
7780 C       i             i                                                        C
7781 C                                                                              C
7782 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7783 C
7784 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7785 C           energy moment and not to the cluster cumulant.
7786       iti=itortyp(itype(i))
7787       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7788         itj1=itortyp(itype(j+1))
7789       else
7790         itj1=ntortyp+1
7791       endif
7792       itk=itortyp(itype(k))
7793       itk1=itortyp(itype(k+1))
7794       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7795         itl1=itortyp(itype(l+1))
7796       else
7797         itl1=ntortyp+1
7798       endif
7799 #ifdef MOMENT
7800       s1=dip(4,jj,i)*dip(4,kk,k)
7801 #endif
7802       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7803       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7804       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7805       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7806       call transpose2(EE(1,1,itk),auxmat(1,1))
7807       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7808       vv(1)=pizda(1,1)+pizda(2,2)
7809       vv(2)=pizda(2,1)-pizda(1,2)
7810       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7811 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7812 #ifdef MOMENT
7813       eello6_graph3=-(s1+s2+s3+s4)
7814 #else
7815       eello6_graph3=-(s2+s3+s4)
7816 #endif
7817 c      eello6_graph3=-s4
7818       if (.not. calc_grad) return
7819 C Derivatives in gamma(k-1)
7820       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7821       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7822       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7823       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7824 C Derivatives in gamma(l-1)
7825       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7826       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7827       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7828       vv(1)=pizda(1,1)+pizda(2,2)
7829       vv(2)=pizda(2,1)-pizda(1,2)
7830       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7831       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7832 C Cartesian derivatives.
7833       do iii=1,2
7834         do kkk=1,5
7835           do lll=1,3
7836 #ifdef MOMENT
7837             if (iii.eq.1) then
7838               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7839             else
7840               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7841             endif
7842 #endif
7843             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7844      &        auxvec(1))
7845             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7846             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7847      &        auxvec(1))
7848             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7849             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7850      &        pizda(1,1))
7851             vv(1)=pizda(1,1)+pizda(2,2)
7852             vv(2)=pizda(2,1)-pizda(1,2)
7853             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7854 #ifdef MOMENT
7855             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7856 #else
7857             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7858 #endif
7859             if (swap) then
7860               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7861             else
7862               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7863             endif
7864 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7865           enddo
7866         enddo
7867       enddo
7868       return
7869       end
7870 c----------------------------------------------------------------------------
7871       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7872       implicit real*8 (a-h,o-z)
7873       include 'DIMENSIONS'
7874       include 'DIMENSIONS.ZSCOPT'
7875       include 'COMMON.IOUNITS'
7876       include 'COMMON.CHAIN'
7877       include 'COMMON.DERIV'
7878       include 'COMMON.INTERACT'
7879       include 'COMMON.CONTACTS'
7880       include 'COMMON.TORSION'
7881       include 'COMMON.VAR'
7882       include 'COMMON.GEO'
7883       include 'COMMON.FFIELD'
7884       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7885      & auxvec1(2),auxmat1(2,2)
7886       logical swap
7887 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7888 C                                                                              C
7889 C      Parallel       Antiparallel                                             C
7890 C                                                                              C
7891 C          o             o                                                     C
7892 C         /l\   /   \   /j\                                                    C
7893 C        /   \ /     \ /   \                                                   C
7894 C       /| o |o       o| o |\                                                  C
7895 C     \ j|/k\|      \  |/k\|l                                                  C
7896 C      \ /   \       \ /   \                                                   C
7897 C       o     \       o     \                                                  C
7898 C       i             i                                                        C
7899 C                                                                              C
7900 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7901 C
7902 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7903 C           energy moment and not to the cluster cumulant.
7904 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7905       iti=itortyp(itype(i))
7906       itj=itortyp(itype(j))
7907       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7908         itj1=itortyp(itype(j+1))
7909       else
7910         itj1=ntortyp+1
7911       endif
7912       itk=itortyp(itype(k))
7913       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7914         itk1=itortyp(itype(k+1))
7915       else
7916         itk1=ntortyp+1
7917       endif
7918       itl=itortyp(itype(l))
7919       if (l.lt.nres-1) then
7920         itl1=itortyp(itype(l+1))
7921       else
7922         itl1=ntortyp+1
7923       endif
7924 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7925 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7926 cd     & ' itl',itl,' itl1',itl1
7927 #ifdef MOMENT
7928       if (imat.eq.1) then
7929         s1=dip(3,jj,i)*dip(3,kk,k)
7930       else
7931         s1=dip(2,jj,j)*dip(2,kk,l)
7932       endif
7933 #endif
7934       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7935       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7936       if (j.eq.l+1) then
7937         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7938         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7939       else
7940         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7941         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7942       endif
7943       call transpose2(EUg(1,1,k),auxmat(1,1))
7944       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7945       vv(1)=pizda(1,1)-pizda(2,2)
7946       vv(2)=pizda(2,1)+pizda(1,2)
7947       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7948 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7949 #ifdef MOMENT
7950       eello6_graph4=-(s1+s2+s3+s4)
7951 #else
7952       eello6_graph4=-(s2+s3+s4)
7953 #endif
7954       if (.not. calc_grad) return
7955 C Derivatives in gamma(i-1)
7956       if (i.gt.1) then
7957 #ifdef MOMENT
7958         if (imat.eq.1) then
7959           s1=dipderg(2,jj,i)*dip(3,kk,k)
7960         else
7961           s1=dipderg(4,jj,j)*dip(2,kk,l)
7962         endif
7963 #endif
7964         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7965         if (j.eq.l+1) then
7966           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7967           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7968         else
7969           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7970           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7971         endif
7972         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7973         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7974 cd          write (2,*) 'turn6 derivatives'
7975 #ifdef MOMENT
7976           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7977 #else
7978           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7979 #endif
7980         else
7981 #ifdef MOMENT
7982           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7983 #else
7984           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7985 #endif
7986         endif
7987       endif
7988 C Derivatives in gamma(k-1)
7989 #ifdef MOMENT
7990       if (imat.eq.1) then
7991         s1=dip(3,jj,i)*dipderg(2,kk,k)
7992       else
7993         s1=dip(2,jj,j)*dipderg(4,kk,l)
7994       endif
7995 #endif
7996       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7997       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7998       if (j.eq.l+1) then
7999         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8000         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8001       else
8002         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8003         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8004       endif
8005       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8006       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8007       vv(1)=pizda(1,1)-pizda(2,2)
8008       vv(2)=pizda(2,1)+pizda(1,2)
8009       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8010       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8011 #ifdef MOMENT
8012         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8013 #else
8014         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8015 #endif
8016       else
8017 #ifdef MOMENT
8018         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8019 #else
8020         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8021 #endif
8022       endif
8023 C Derivatives in gamma(j-1) or gamma(l-1)
8024       if (l.eq.j+1 .and. l.gt.1) then
8025         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8026         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8027         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8028         vv(1)=pizda(1,1)-pizda(2,2)
8029         vv(2)=pizda(2,1)+pizda(1,2)
8030         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8031         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8032       else if (j.gt.1) then
8033         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8034         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8035         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8036         vv(1)=pizda(1,1)-pizda(2,2)
8037         vv(2)=pizda(2,1)+pizda(1,2)
8038         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8039         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8040           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8041         else
8042           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8043         endif
8044       endif
8045 C Cartesian derivatives.
8046       do iii=1,2
8047         do kkk=1,5
8048           do lll=1,3
8049 #ifdef MOMENT
8050             if (iii.eq.1) then
8051               if (imat.eq.1) then
8052                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8053               else
8054                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8055               endif
8056             else
8057               if (imat.eq.1) then
8058                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8059               else
8060                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8061               endif
8062             endif
8063 #endif
8064             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8065      &        auxvec(1))
8066             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8067             if (j.eq.l+1) then
8068               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8069      &          b1(1,itj1),auxvec(1))
8070               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8071             else
8072               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8073      &          b1(1,itl1),auxvec(1))
8074               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8075             endif
8076             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8077      &        pizda(1,1))
8078             vv(1)=pizda(1,1)-pizda(2,2)
8079             vv(2)=pizda(2,1)+pizda(1,2)
8080             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8081             if (swap) then
8082               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8083 #ifdef MOMENT
8084                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8085      &             -(s1+s2+s4)
8086 #else
8087                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8088      &             -(s2+s4)
8089 #endif
8090                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8091               else
8092 #ifdef MOMENT
8093                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8094 #else
8095                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8096 #endif
8097                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8098               endif
8099             else
8100 #ifdef MOMENT
8101               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8102 #else
8103               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8104 #endif
8105               if (l.eq.j+1) then
8106                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8107               else
8108                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8109               endif
8110             endif
8111           enddo
8112         enddo
8113       enddo
8114       return
8115       end
8116 c----------------------------------------------------------------------------
8117       double precision function eello_turn6(i,jj,kk)
8118       implicit real*8 (a-h,o-z)
8119       include 'DIMENSIONS'
8120       include 'DIMENSIONS.ZSCOPT'
8121       include 'COMMON.IOUNITS'
8122       include 'COMMON.CHAIN'
8123       include 'COMMON.DERIV'
8124       include 'COMMON.INTERACT'
8125       include 'COMMON.CONTACTS'
8126       include 'COMMON.TORSION'
8127       include 'COMMON.VAR'
8128       include 'COMMON.GEO'
8129       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8130      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8131      &  ggg1(3),ggg2(3)
8132       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8133      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8134 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8135 C           the respective energy moment and not to the cluster cumulant.
8136       eello_turn6=0.0d0
8137       j=i+4
8138       k=i+1
8139       l=i+3
8140       iti=itortyp(itype(i))
8141       itk=itortyp(itype(k))
8142       itk1=itortyp(itype(k+1))
8143       itl=itortyp(itype(l))
8144       itj=itortyp(itype(j))
8145 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8146 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8147 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8148 cd        eello6=0.0d0
8149 cd        return
8150 cd      endif
8151 cd      write (iout,*)
8152 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8153 cd     &   ' and',k,l
8154 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8155       do iii=1,2
8156         do kkk=1,5
8157           do lll=1,3
8158             derx_turn(lll,kkk,iii)=0.0d0
8159           enddo
8160         enddo
8161       enddo
8162 cd      eij=1.0d0
8163 cd      ekl=1.0d0
8164 cd      ekont=1.0d0
8165       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8166 cd      eello6_5=0.0d0
8167 cd      write (2,*) 'eello6_5',eello6_5
8168 #ifdef MOMENT
8169       call transpose2(AEA(1,1,1),auxmat(1,1))
8170       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8171       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8172       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8173 #else
8174       s1 = 0.0d0
8175 #endif
8176       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8177       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8178       s2 = scalar2(b1(1,itk),vtemp1(1))
8179 #ifdef MOMENT
8180       call transpose2(AEA(1,1,2),atemp(1,1))
8181       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8182       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8183       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8184 #else
8185       s8=0.0d0
8186 #endif
8187       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8188       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8189       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8190 #ifdef MOMENT
8191       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8192       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8193       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8194       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8195       ss13 = scalar2(b1(1,itk),vtemp4(1))
8196       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8197 #else
8198       s13=0.0d0
8199 #endif
8200 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8201 c      s1=0.0d0
8202 c      s2=0.0d0
8203 c      s8=0.0d0
8204 c      s12=0.0d0
8205 c      s13=0.0d0
8206       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8207       if (calc_grad) then
8208 C Derivatives in gamma(i+2)
8209 #ifdef MOMENT
8210       call transpose2(AEA(1,1,1),auxmatd(1,1))
8211       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8212       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8213       call transpose2(AEAderg(1,1,2),atempd(1,1))
8214       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8215       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8216 #else
8217       s8d=0.0d0
8218 #endif
8219       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8220       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8221       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8222 c      s1d=0.0d0
8223 c      s2d=0.0d0
8224 c      s8d=0.0d0
8225 c      s12d=0.0d0
8226 c      s13d=0.0d0
8227       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8228 C Derivatives in gamma(i+3)
8229 #ifdef MOMENT
8230       call transpose2(AEA(1,1,1),auxmatd(1,1))
8231       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8232       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8233       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8234 #else
8235       s1d=0.0d0
8236 #endif
8237       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8238       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8239       s2d = scalar2(b1(1,itk),vtemp1d(1))
8240 #ifdef MOMENT
8241       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8242       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8243 #endif
8244       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8245 #ifdef MOMENT
8246       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8247       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8248       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8249 #else
8250       s13d=0.0d0
8251 #endif
8252 c      s1d=0.0d0
8253 c      s2d=0.0d0
8254 c      s8d=0.0d0
8255 c      s12d=0.0d0
8256 c      s13d=0.0d0
8257 #ifdef MOMENT
8258       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8259      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8260 #else
8261       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8262      &               -0.5d0*ekont*(s2d+s12d)
8263 #endif
8264 C Derivatives in gamma(i+4)
8265       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8266       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8267       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8268 #ifdef MOMENT
8269       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8270       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8271       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8272 #else
8273       s13d = 0.0d0
8274 #endif
8275 c      s1d=0.0d0
8276 c      s2d=0.0d0
8277 c      s8d=0.0d0
8278 C      s12d=0.0d0
8279 c      s13d=0.0d0
8280 #ifdef MOMENT
8281       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8282 #else
8283       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8284 #endif
8285 C Derivatives in gamma(i+5)
8286 #ifdef MOMENT
8287       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8288       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8289       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8290 #else
8291       s1d = 0.0d0
8292 #endif
8293       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8294       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8295       s2d = scalar2(b1(1,itk),vtemp1d(1))
8296 #ifdef MOMENT
8297       call transpose2(AEA(1,1,2),atempd(1,1))
8298       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8299       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8300 #else
8301       s8d = 0.0d0
8302 #endif
8303       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8304       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8305 #ifdef MOMENT
8306       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8307       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8308       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8309 #else
8310       s13d = 0.0d0
8311 #endif
8312 c      s1d=0.0d0
8313 c      s2d=0.0d0
8314 c      s8d=0.0d0
8315 c      s12d=0.0d0
8316 c      s13d=0.0d0
8317 #ifdef MOMENT
8318       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8319      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8320 #else
8321       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8322      &               -0.5d0*ekont*(s2d+s12d)
8323 #endif
8324 C Cartesian derivatives
8325       do iii=1,2
8326         do kkk=1,5
8327           do lll=1,3
8328 #ifdef MOMENT
8329             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8330             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8331             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8332 #else
8333             s1d = 0.0d0
8334 #endif
8335             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8336             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8337      &          vtemp1d(1))
8338             s2d = scalar2(b1(1,itk),vtemp1d(1))
8339 #ifdef MOMENT
8340             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8341             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8342             s8d = -(atempd(1,1)+atempd(2,2))*
8343      &           scalar2(cc(1,1,itl),vtemp2(1))
8344 #else
8345             s8d = 0.0d0
8346 #endif
8347             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8348      &           auxmatd(1,1))
8349             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8350             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8351 c      s1d=0.0d0
8352 c      s2d=0.0d0
8353 c      s8d=0.0d0
8354 c      s12d=0.0d0
8355 c      s13d=0.0d0
8356 #ifdef MOMENT
8357             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8358      &        - 0.5d0*(s1d+s2d)
8359 #else
8360             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8361      &        - 0.5d0*s2d
8362 #endif
8363 #ifdef MOMENT
8364             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8365      &        - 0.5d0*(s8d+s12d)
8366 #else
8367             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8368      &        - 0.5d0*s12d
8369 #endif
8370           enddo
8371         enddo
8372       enddo
8373 #ifdef MOMENT
8374       do kkk=1,5
8375         do lll=1,3
8376           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8377      &      achuj_tempd(1,1))
8378           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8379           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8380           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8381           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8382           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8383      &      vtemp4d(1))
8384           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8385           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8386           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8387         enddo
8388       enddo
8389 #endif
8390 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8391 cd     &  16*eel_turn6_num
8392 cd      goto 1112
8393       if (j.lt.nres-1) then
8394         j1=j+1
8395         j2=j-1
8396       else
8397         j1=j-1
8398         j2=j-2
8399       endif
8400       if (l.lt.nres-1) then
8401         l1=l+1
8402         l2=l-1
8403       else
8404         l1=l-1
8405         l2=l-2
8406       endif
8407       do ll=1,3
8408         ggg1(ll)=eel_turn6*g_contij(ll,1)
8409         ggg2(ll)=eel_turn6*g_contij(ll,2)
8410         ghalf=0.5d0*ggg1(ll)
8411 cd        ghalf=0.0d0
8412         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8413      &    +ekont*derx_turn(ll,2,1)
8414         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8415         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8416      &    +ekont*derx_turn(ll,4,1)
8417         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8418         ghalf=0.5d0*ggg2(ll)
8419 cd        ghalf=0.0d0
8420         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8421      &    +ekont*derx_turn(ll,2,2)
8422         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8423         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8424      &    +ekont*derx_turn(ll,4,2)
8425         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8426       enddo
8427 cd      goto 1112
8428       do m=i+1,j-1
8429         do ll=1,3
8430           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8431         enddo
8432       enddo
8433       do m=k+1,l-1
8434         do ll=1,3
8435           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8436         enddo
8437       enddo
8438 1112  continue
8439       do m=i+2,j2
8440         do ll=1,3
8441           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8442         enddo
8443       enddo
8444       do m=k+2,l2
8445         do ll=1,3
8446           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8447         enddo
8448       enddo
8449 cd      do iii=1,nres-3
8450 cd        write (2,*) iii,g_corr6_loc(iii)
8451 cd      enddo
8452       endif
8453       eello_turn6=ekont*eel_turn6
8454 cd      write (2,*) 'ekont',ekont
8455 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8456       return
8457       end
8458 crc-------------------------------------------------
8459       SUBROUTINE MATVEC2(A1,V1,V2)
8460       implicit real*8 (a-h,o-z)
8461       include 'DIMENSIONS'
8462       DIMENSION A1(2,2),V1(2),V2(2)
8463 c      DO 1 I=1,2
8464 c        VI=0.0
8465 c        DO 3 K=1,2
8466 c    3     VI=VI+A1(I,K)*V1(K)
8467 c        Vaux(I)=VI
8468 c    1 CONTINUE
8469
8470       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8471       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8472
8473       v2(1)=vaux1
8474       v2(2)=vaux2
8475       END
8476 C---------------------------------------
8477       SUBROUTINE MATMAT2(A1,A2,A3)
8478       implicit real*8 (a-h,o-z)
8479       include 'DIMENSIONS'
8480       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8481 c      DIMENSION AI3(2,2)
8482 c        DO  J=1,2
8483 c          A3IJ=0.0
8484 c          DO K=1,2
8485 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8486 c          enddo
8487 c          A3(I,J)=A3IJ
8488 c       enddo
8489 c      enddo
8490
8491       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8492       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8493       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8494       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8495
8496       A3(1,1)=AI3_11
8497       A3(2,1)=AI3_21
8498       A3(1,2)=AI3_12
8499       A3(2,2)=AI3_22
8500       END
8501
8502 c-------------------------------------------------------------------------
8503       double precision function scalar2(u,v)
8504       implicit none
8505       double precision u(2),v(2)
8506       double precision sc
8507       integer i
8508       scalar2=u(1)*v(1)+u(2)*v(2)
8509       return
8510       end
8511
8512 C-----------------------------------------------------------------------------
8513
8514       subroutine transpose2(a,at)
8515       implicit none
8516       double precision a(2,2),at(2,2)
8517       at(1,1)=a(1,1)
8518       at(1,2)=a(2,1)
8519       at(2,1)=a(1,2)
8520       at(2,2)=a(2,2)
8521       return
8522       end
8523 c--------------------------------------------------------------------------
8524       subroutine transpose(n,a,at)
8525       implicit none
8526       integer n,i,j
8527       double precision a(n,n),at(n,n)
8528       do i=1,n
8529         do j=1,n
8530           at(j,i)=a(i,j)
8531         enddo
8532       enddo
8533       return
8534       end
8535 C---------------------------------------------------------------------------
8536       subroutine prodmat3(a1,a2,kk,transp,prod)
8537       implicit none
8538       integer i,j
8539       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8540       logical transp
8541 crc      double precision auxmat(2,2),prod_(2,2)
8542
8543       if (transp) then
8544 crc        call transpose2(kk(1,1),auxmat(1,1))
8545 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8546 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8547
8548            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8549      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8550            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8551      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8552            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8553      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8554            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8555      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8556
8557       else
8558 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8559 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8560
8561            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8562      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8563            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8564      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8565            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8566      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8567            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8568      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8569
8570       endif
8571 c      call transpose2(a2(1,1),a2t(1,1))
8572
8573 crc      print *,transp
8574 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8575 crc      print *,((prod(i,j),i=1,2),j=1,2)
8576
8577       return
8578       end
8579 C-----------------------------------------------------------------------------
8580       double precision function scalar(u,v)
8581       implicit none
8582       double precision u(3),v(3)
8583       double precision sc
8584       integer i
8585       sc=0.0d0
8586       do i=1,3
8587         sc=sc+u(i)*v(i)
8588       enddo
8589       scalar=sc
8590       return
8591       end
8592 C-----------------------------------------------------------------------
8593       double precision function sscale(r)
8594       double precision r,gamm
8595       include "COMMON.SPLITELE"
8596       if(r.lt.r_cut-rlamb) then
8597         sscale=1.0d0
8598       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8599         gamm=(r-(r_cut-rlamb))/rlamb
8600         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8601       else
8602         sscale=0d0
8603       endif
8604       return
8605       end
8606 C-----------------------------------------------------------------------
8607 C-----------------------------------------------------------------------
8608       double precision function sscagrad(r)
8609       double precision r,gamm
8610       include "COMMON.SPLITELE"
8611       if(r.lt.r_cut-rlamb) then
8612         sscagrad=0.0d0
8613       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8614         gamm=(r-(r_cut-rlamb))/rlamb
8615         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8616       else
8617         sscagrad=0.0d0
8618       endif
8619       return
8620       end
8621 C-----------------------------------------------------------------------
8622 C-----------------------------------------------------------------------
8623       double precision function sscalelip(r)
8624       double precision r,gamm
8625       include "COMMON.SPLITELE"
8626 C      if(r.lt.r_cut-rlamb) then
8627 C        sscale=1.0d0
8628 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8629 C        gamm=(r-(r_cut-rlamb))/rlamb
8630         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8631 C      else
8632 C        sscale=0d0
8633 C      endif
8634       return
8635       end
8636 C-----------------------------------------------------------------------
8637       double precision function sscagradlip(r)
8638       double precision r,gamm
8639       include "COMMON.SPLITELE"
8640 C     if(r.lt.r_cut-rlamb) then
8641 C        sscagrad=0.0d0
8642 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8643 C        gamm=(r-(r_cut-rlamb))/rlamb
8644         sscagradlip=r*(6*r-6.0d0)
8645 C      else
8646 C        sscagrad=0.0d0
8647 C      endif
8648       return
8649       end
8650