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       include 'COMMON.TORCNSTR'
4450       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4451      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4452      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4453      & sinph1ph2(maxdouble,maxdouble)
4454       logical lprn /.false./, lprn1 /.false./
4455       etheta=0.0D0
4456 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4457       do i=ithet_start,ithet_end
4458 c        if (i.eq.2) cycle
4459 c        print *,i,itype(i-1),itype(i),itype(i-2)
4460         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
4461      &  .or.(itype(i).eq.ntyp1)) cycle
4462 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
4463
4464         if (iabs(itype(i+1)).eq.20) iblock=2
4465         if (iabs(itype(i+1)).ne.20) iblock=1
4466         dethetai=0.0d0
4467         dephii=0.0d0
4468         dephii1=0.0d0
4469         theti2=0.5d0*theta(i)
4470         ityp2=ithetyp((itype(i-1)))
4471         do k=1,nntheterm
4472           coskt(k)=dcos(k*theti2)
4473           sinkt(k)=dsin(k*theti2)
4474         enddo
4475         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4476 #ifdef OSF
4477           phii=phi(i)
4478           if (phii.ne.phii) phii=150.0
4479 #else
4480           phii=phi(i)
4481 #endif
4482           ityp1=ithetyp((itype(i-2)))
4483           do k=1,nsingle
4484             cosph1(k)=dcos(k*phii)
4485             sinph1(k)=dsin(k*phii)
4486           enddo
4487         else
4488           phii=0.0d0
4489           ityp1=ithetyp(itype(i-2))
4490           do k=1,nsingle
4491             cosph1(k)=0.0d0
4492             sinph1(k)=0.0d0
4493           enddo
4494         endif
4495         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4496 #ifdef OSF
4497           phii1=phi(i+1)
4498           if (phii1.ne.phii1) phii1=150.0
4499           phii1=pinorm(phii1)
4500 #else
4501           phii1=phi(i+1)
4502 #endif
4503           ityp3=ithetyp((itype(i)))
4504           do k=1,nsingle
4505             cosph2(k)=dcos(k*phii1)
4506             sinph2(k)=dsin(k*phii1)
4507           enddo
4508         else
4509           phii1=0.0d0
4510           ityp3=ithetyp(itype(i))
4511           do k=1,nsingle
4512             cosph2(k)=0.0d0
4513             sinph2(k)=0.0d0
4514           enddo
4515         endif
4516 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4517 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4518 c        call flush(iout)
4519         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4520         do k=1,ndouble
4521           do l=1,k-1
4522             ccl=cosph1(l)*cosph2(k-l)
4523             ssl=sinph1(l)*sinph2(k-l)
4524             scl=sinph1(l)*cosph2(k-l)
4525             csl=cosph1(l)*sinph2(k-l)
4526             cosph1ph2(l,k)=ccl-ssl
4527             cosph1ph2(k,l)=ccl+ssl
4528             sinph1ph2(l,k)=scl+csl
4529             sinph1ph2(k,l)=scl-csl
4530           enddo
4531         enddo
4532         if (lprn) then
4533         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4534      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4535         write (iout,*) "coskt and sinkt"
4536         do k=1,nntheterm
4537           write (iout,*) k,coskt(k),sinkt(k)
4538         enddo
4539         endif
4540         do k=1,ntheterm
4541           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4542           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4543      &      *coskt(k)
4544           if (lprn)
4545      &    write (iout,*) "k",k,"
4546      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4547      &     " ethetai",ethetai
4548         enddo
4549         if (lprn) then
4550         write (iout,*) "cosph and sinph"
4551         do k=1,nsingle
4552           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4553         enddo
4554         write (iout,*) "cosph1ph2 and sinph2ph2"
4555         do k=2,ndouble
4556           do l=1,k-1
4557             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4558      &         sinph1ph2(l,k),sinph1ph2(k,l)
4559           enddo
4560         enddo
4561         write(iout,*) "ethetai",ethetai
4562         endif
4563         do m=1,ntheterm2
4564           do k=1,nsingle
4565             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4566      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4567      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4568      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4569             ethetai=ethetai+sinkt(m)*aux
4570             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4571             dephii=dephii+k*sinkt(m)*(
4572      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4573      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4574             dephii1=dephii1+k*sinkt(m)*(
4575      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4576      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4577             if (lprn)
4578      &      write (iout,*) "m",m," k",k," bbthet",
4579      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4580      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4581      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4582      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4583           enddo
4584         enddo
4585         if (lprn)
4586      &  write(iout,*) "ethetai",ethetai
4587         do m=1,ntheterm3
4588           do k=2,ndouble
4589             do l=1,k-1
4590               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4591      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4592      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4593      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4594               ethetai=ethetai+sinkt(m)*aux
4595               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4596               dephii=dephii+l*sinkt(m)*(
4597      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4598      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4599      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4600      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4601               dephii1=dephii1+(k-l)*sinkt(m)*(
4602      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4603      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4604      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4605      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4606               if (lprn) then
4607               write (iout,*) "m",m," k",k," l",l," ffthet",
4608      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4609      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4610      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4611      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4612      &            " ethetai",ethetai
4613               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4614      &            cosph1ph2(k,l)*sinkt(m),
4615      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4616               endif
4617             enddo
4618           enddo
4619         enddo
4620 10      continue
4621         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4622      &   i,theta(i)*rad2deg,phii*rad2deg,
4623      &   phii1*rad2deg,ethetai
4624         etheta=etheta+ethetai
4625         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4626         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4627 c        gloc(nphi+i-2,icg)=wang*dethetai
4628         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4629       enddo
4630 C now constrains
4631       ethetacnstr=0.0d0
4632 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4633       do i=1,ntheta_constr
4634         itheta=itheta_constr(i)
4635         thetiii=theta(itheta)
4636         difi=pinorm(thetiii-theta_constr0(i))
4637         if (difi.gt.theta_drange(i)) then
4638           difi=difi-theta_drange(i)
4639           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4640           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4641      &    +for_thet_constr(i)*difi**3
4642         else if (difi.lt.-drange(i)) then
4643           difi=difi+drange(i)
4644           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4645           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4646      &    +for_thet_constr(i)*difi**3
4647         else
4648           difi=0.0
4649         endif
4650 C       if (energy_dec) then
4651 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4652 C     &    i,itheta,rad2deg*thetiii,
4653 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4654 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4655 C     &    gloc(itheta+nphi-2,icg)
4656 C        endif
4657       enddo
4658       return
4659       end
4660
4661 #endif
4662 #ifdef CRYST_SC
4663 c-----------------------------------------------------------------------------
4664       subroutine esc(escloc)
4665 C Calculate the local energy of a side chain and its derivatives in the
4666 C corresponding virtual-bond valence angles THETA and the spherical angles
4667 C ALPHA and OMEGA.
4668       implicit real*8 (a-h,o-z)
4669       include 'DIMENSIONS'
4670       include 'DIMENSIONS.ZSCOPT'
4671       include 'COMMON.GEO'
4672       include 'COMMON.LOCAL'
4673       include 'COMMON.VAR'
4674       include 'COMMON.INTERACT'
4675       include 'COMMON.DERIV'
4676       include 'COMMON.CHAIN'
4677       include 'COMMON.IOUNITS'
4678       include 'COMMON.NAMES'
4679       include 'COMMON.FFIELD'
4680       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4681      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4682       common /sccalc/ time11,time12,time112,theti,it,nlobit
4683       delta=0.02d0*pi
4684       escloc=0.0D0
4685 C      write (iout,*) 'ESC'
4686       do i=loc_start,loc_end
4687         it=itype(i)
4688         if (it.eq.ntyp1) cycle
4689         if (it.eq.10) goto 1
4690         nlobit=nlob(iabs(it))
4691 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4692 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4693         theti=theta(i+1)-pipol
4694         x(1)=dtan(theti)
4695         x(2)=alph(i)
4696         x(3)=omeg(i)
4697 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
4698
4699         if (x(2).gt.pi-delta) then
4700           xtemp(1)=x(1)
4701           xtemp(2)=pi-delta
4702           xtemp(3)=x(3)
4703           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4704           xtemp(2)=pi
4705           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4706           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4707      &        escloci,dersc(2))
4708           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4709      &        ddersc0(1),dersc(1))
4710           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4711      &        ddersc0(3),dersc(3))
4712           xtemp(2)=pi-delta
4713           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4714           xtemp(2)=pi
4715           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4716           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4717      &            dersc0(2),esclocbi,dersc02)
4718           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4719      &            dersc12,dersc01)
4720           call splinthet(x(2),0.5d0*delta,ss,ssd)
4721           dersc0(1)=dersc01
4722           dersc0(2)=dersc02
4723           dersc0(3)=0.0d0
4724           do k=1,3
4725             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4726           enddo
4727           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4728           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4729      &             esclocbi,ss,ssd
4730           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4731 c         escloci=esclocbi
4732 c         write (iout,*) escloci
4733         else if (x(2).lt.delta) then
4734           xtemp(1)=x(1)
4735           xtemp(2)=delta
4736           xtemp(3)=x(3)
4737           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4738           xtemp(2)=0.0d0
4739           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4740           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4741      &        escloci,dersc(2))
4742           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4743      &        ddersc0(1),dersc(1))
4744           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4745      &        ddersc0(3),dersc(3))
4746           xtemp(2)=delta
4747           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4748           xtemp(2)=0.0d0
4749           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4750           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4751      &            dersc0(2),esclocbi,dersc02)
4752           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4753      &            dersc12,dersc01)
4754           dersc0(1)=dersc01
4755           dersc0(2)=dersc02
4756           dersc0(3)=0.0d0
4757           call splinthet(x(2),0.5d0*delta,ss,ssd)
4758           do k=1,3
4759             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4760           enddo
4761           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4762 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4763 c     &             esclocbi,ss,ssd
4764           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4765 C         write (iout,*) 'i=',i, escloci
4766         else
4767           call enesc(x,escloci,dersc,ddummy,.false.)
4768         endif
4769
4770         escloc=escloc+escloci
4771 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
4772             write (iout,'(a6,i5,0pf7.3)')
4773      &     'escloc',i,escloci
4774
4775         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4776      &   wscloc*dersc(1)
4777         gloc(ialph(i,1),icg)=wscloc*dersc(2)
4778         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
4779     1   continue
4780       enddo
4781       return
4782       end
4783 C---------------------------------------------------------------------------
4784       subroutine enesc(x,escloci,dersc,ddersc,mixed)
4785       implicit real*8 (a-h,o-z)
4786       include 'DIMENSIONS'
4787       include 'COMMON.GEO'
4788       include 'COMMON.LOCAL'
4789       include 'COMMON.IOUNITS'
4790       common /sccalc/ time11,time12,time112,theti,it,nlobit
4791       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
4792       double precision contr(maxlob,-1:1)
4793       logical mixed
4794 c       write (iout,*) 'it=',it,' nlobit=',nlobit
4795         escloc_i=0.0D0
4796         do j=1,3
4797           dersc(j)=0.0D0
4798           if (mixed) ddersc(j)=0.0d0
4799         enddo
4800         x3=x(3)
4801
4802 C Because of periodicity of the dependence of the SC energy in omega we have
4803 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
4804 C To avoid underflows, first compute & store the exponents.
4805
4806         do iii=-1,1
4807
4808           x(3)=x3+iii*dwapi
4809
4810           do j=1,nlobit
4811             do k=1,3
4812               z(k)=x(k)-censc(k,j,it)
4813             enddo
4814             do k=1,3
4815               Axk=0.0D0
4816               do l=1,3
4817                 Axk=Axk+gaussc(l,k,j,it)*z(l)
4818               enddo
4819               Ax(k,j,iii)=Axk
4820             enddo
4821             expfac=0.0D0
4822             do k=1,3
4823               expfac=expfac+Ax(k,j,iii)*z(k)
4824             enddo
4825             contr(j,iii)=expfac
4826           enddo ! j
4827
4828         enddo ! iii
4829
4830         x(3)=x3
4831 C As in the case of ebend, we want to avoid underflows in exponentiation and
4832 C subsequent NaNs and INFs in energy calculation.
4833 C Find the largest exponent
4834         emin=contr(1,-1)
4835         do iii=-1,1
4836           do j=1,nlobit
4837             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
4838           enddo
4839         enddo
4840         emin=0.5D0*emin
4841 cd      print *,'it=',it,' emin=',emin
4842
4843 C Compute the contribution to SC energy and derivatives
4844         do iii=-1,1
4845
4846           do j=1,nlobit
4847             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
4848 cd          print *,'j=',j,' expfac=',expfac
4849             escloc_i=escloc_i+expfac
4850             do k=1,3
4851               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
4852             enddo
4853             if (mixed) then
4854               do k=1,3,2
4855                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
4856      &            +gaussc(k,2,j,it))*expfac
4857               enddo
4858             endif
4859           enddo
4860
4861         enddo ! iii
4862
4863         dersc(1)=dersc(1)/cos(theti)**2
4864         ddersc(1)=ddersc(1)/cos(theti)**2
4865         ddersc(3)=ddersc(3)
4866
4867         escloci=-(dlog(escloc_i)-emin)
4868         do j=1,3
4869           dersc(j)=dersc(j)/escloc_i
4870         enddo
4871         if (mixed) then
4872           do j=1,3,2
4873             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
4874           enddo
4875         endif
4876       return
4877       end
4878 C------------------------------------------------------------------------------
4879       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
4880       implicit real*8 (a-h,o-z)
4881       include 'DIMENSIONS'
4882       include 'COMMON.GEO'
4883       include 'COMMON.LOCAL'
4884       include 'COMMON.IOUNITS'
4885       common /sccalc/ time11,time12,time112,theti,it,nlobit
4886       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
4887       double precision contr(maxlob)
4888       logical mixed
4889
4890       escloc_i=0.0D0
4891
4892       do j=1,3
4893         dersc(j)=0.0D0
4894       enddo
4895
4896       do j=1,nlobit
4897         do k=1,2
4898           z(k)=x(k)-censc(k,j,it)
4899         enddo
4900         z(3)=dwapi
4901         do k=1,3
4902           Axk=0.0D0
4903           do l=1,3
4904             Axk=Axk+gaussc(l,k,j,it)*z(l)
4905           enddo
4906           Ax(k,j)=Axk
4907         enddo
4908         expfac=0.0D0
4909         do k=1,3
4910           expfac=expfac+Ax(k,j)*z(k)
4911         enddo
4912         contr(j)=expfac
4913       enddo ! j
4914
4915 C As in the case of ebend, we want to avoid underflows in exponentiation and
4916 C subsequent NaNs and INFs in energy calculation.
4917 C Find the largest exponent
4918       emin=contr(1)
4919       do j=1,nlobit
4920         if (emin.gt.contr(j)) emin=contr(j)
4921       enddo
4922       emin=0.5D0*emin
4923
4924 C Compute the contribution to SC energy and derivatives
4925
4926       dersc12=0.0d0
4927       do j=1,nlobit
4928         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
4929         escloc_i=escloc_i+expfac
4930         do k=1,2
4931           dersc(k)=dersc(k)+Ax(k,j)*expfac
4932         enddo
4933         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
4934      &            +gaussc(1,2,j,it))*expfac
4935         dersc(3)=0.0d0
4936       enddo
4937
4938       dersc(1)=dersc(1)/cos(theti)**2
4939       dersc12=dersc12/cos(theti)**2
4940       escloci=-(dlog(escloc_i)-emin)
4941       do j=1,2
4942         dersc(j)=dersc(j)/escloc_i
4943       enddo
4944       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
4945       return
4946       end
4947 #else
4948 c----------------------------------------------------------------------------------
4949       subroutine esc(escloc)
4950 C Calculate the local energy of a side chain and its derivatives in the
4951 C corresponding virtual-bond valence angles THETA and the spherical angles
4952 C ALPHA and OMEGA derived from AM1 all-atom calculations.
4953 C added by Urszula Kozlowska. 07/11/2007
4954 C
4955       implicit real*8 (a-h,o-z)
4956       include 'DIMENSIONS'
4957       include 'DIMENSIONS.ZSCOPT'
4958       include 'DIMENSIONS.FREE'
4959       include 'COMMON.GEO'
4960       include 'COMMON.LOCAL'
4961       include 'COMMON.VAR'
4962       include 'COMMON.SCROT'
4963       include 'COMMON.INTERACT'
4964       include 'COMMON.DERIV'
4965       include 'COMMON.CHAIN'
4966       include 'COMMON.IOUNITS'
4967       include 'COMMON.NAMES'
4968       include 'COMMON.FFIELD'
4969       include 'COMMON.CONTROL'
4970       include 'COMMON.VECTORS'
4971       double precision x_prime(3),y_prime(3),z_prime(3)
4972      &    , sumene,dsc_i,dp2_i,x(65),
4973      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
4974      &    de_dxx,de_dyy,de_dzz,de_dt
4975       double precision s1_t,s1_6_t,s2_t,s2_6_t
4976       double precision
4977      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
4978      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
4979      & dt_dCi(3),dt_dCi1(3)
4980       common /sccalc/ time11,time12,time112,theti,it,nlobit
4981       delta=0.02d0*pi
4982       escloc=0.0D0
4983       do i=loc_start,loc_end
4984         if (itype(i).eq.ntyp1) cycle
4985         costtab(i+1) =dcos(theta(i+1))
4986         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
4987         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
4988         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
4989         cosfac2=0.5d0/(1.0d0+costtab(i+1))
4990         cosfac=dsqrt(cosfac2)
4991         sinfac2=0.5d0/(1.0d0-costtab(i+1))
4992         sinfac=dsqrt(sinfac2)
4993         it=iabs(itype(i))
4994         if (it.eq.10) goto 1
4995 c
4996 C  Compute the axes of tghe local cartesian coordinates system; store in
4997 c   x_prime, y_prime and z_prime
4998 c
4999         do j=1,3
5000           x_prime(j) = 0.00
5001           y_prime(j) = 0.00
5002           z_prime(j) = 0.00
5003         enddo
5004 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5005 C     &   dc_norm(3,i+nres)
5006         do j = 1,3
5007           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5008           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5009         enddo
5010         do j = 1,3
5011           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5012         enddo
5013 c       write (2,*) "i",i
5014 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5015 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5016 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5017 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5018 c      & " xy",scalar(x_prime(1),y_prime(1)),
5019 c      & " xz",scalar(x_prime(1),z_prime(1)),
5020 c      & " yy",scalar(y_prime(1),y_prime(1)),
5021 c      & " yz",scalar(y_prime(1),z_prime(1)),
5022 c      & " zz",scalar(z_prime(1),z_prime(1))
5023 c
5024 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5025 C to local coordinate system. Store in xx, yy, zz.
5026 c
5027         xx=0.0d0
5028         yy=0.0d0
5029         zz=0.0d0
5030         do j = 1,3
5031           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5032           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5033           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5034         enddo
5035
5036         xxtab(i)=xx
5037         yytab(i)=yy
5038         zztab(i)=zz
5039 C
5040 C Compute the energy of the ith side cbain
5041 C
5042 c        write (2,*) "xx",xx," yy",yy," zz",zz
5043         it=iabs(itype(i))
5044         do j = 1,65
5045           x(j) = sc_parmin(j,it)
5046         enddo
5047 #ifdef CHECK_COORD
5048 Cc diagnostics - remove later
5049         xx1 = dcos(alph(2))
5050         yy1 = dsin(alph(2))*dcos(omeg(2))
5051         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5052         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5053      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5054      &    xx1,yy1,zz1
5055 C,"  --- ", xx_w,yy_w,zz_w
5056 c end diagnostics
5057 #endif
5058         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5059      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5060      &   + x(10)*yy*zz
5061         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5062      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5063      & + x(20)*yy*zz
5064         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5065      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5066      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5067      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5068      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5069      &  +x(40)*xx*yy*zz
5070         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5071      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5072      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5073      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5074      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5075      &  +x(60)*xx*yy*zz
5076         dsc_i   = 0.743d0+x(61)
5077         dp2_i   = 1.9d0+x(62)
5078         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5079      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5080         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5081      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5082         s1=(1+x(63))/(0.1d0 + dscp1)
5083         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5084         s2=(1+x(65))/(0.1d0 + dscp2)
5085         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5086         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5087      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5088 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5089 c     &   sumene4,
5090 c     &   dscp1,dscp2,sumene
5091 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5092         escloc = escloc + sumene
5093 c        write (2,*) "escloc",escloc
5094 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5095 c     &  zz,xx,yy
5096         if (.not. calc_grad) goto 1
5097 #ifdef DEBUG
5098 C
5099 C This section to check the numerical derivatives of the energy of ith side
5100 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5101 C #define DEBUG in the code to turn it on.
5102 C
5103         write (2,*) "sumene               =",sumene
5104         aincr=1.0d-7
5105         xxsave=xx
5106         xx=xx+aincr
5107         write (2,*) xx,yy,zz
5108         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5109         de_dxx_num=(sumenep-sumene)/aincr
5110         xx=xxsave
5111         write (2,*) "xx+ sumene from enesc=",sumenep
5112         yysave=yy
5113         yy=yy+aincr
5114         write (2,*) xx,yy,zz
5115         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5116         de_dyy_num=(sumenep-sumene)/aincr
5117         yy=yysave
5118         write (2,*) "yy+ sumene from enesc=",sumenep
5119         zzsave=zz
5120         zz=zz+aincr
5121         write (2,*) xx,yy,zz
5122         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5123         de_dzz_num=(sumenep-sumene)/aincr
5124         zz=zzsave
5125         write (2,*) "zz+ sumene from enesc=",sumenep
5126         costsave=cost2tab(i+1)
5127         sintsave=sint2tab(i+1)
5128         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5129         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5130         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5131         de_dt_num=(sumenep-sumene)/aincr
5132         write (2,*) " t+ sumene from enesc=",sumenep
5133         cost2tab(i+1)=costsave
5134         sint2tab(i+1)=sintsave
5135 C End of diagnostics section.
5136 #endif
5137 C
5138 C Compute the gradient of esc
5139 C
5140         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5141         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5142         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5143         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5144         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5145         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5146         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5147         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5148         pom1=(sumene3*sint2tab(i+1)+sumene1)
5149      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5150         pom2=(sumene4*cost2tab(i+1)+sumene2)
5151      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5152         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5153         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5154      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5155      &  +x(40)*yy*zz
5156         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5157         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5158      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5159      &  +x(60)*yy*zz
5160         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5161      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5162      &        +(pom1+pom2)*pom_dx
5163 #ifdef DEBUG
5164         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5165 #endif
5166 C
5167         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5168         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5169      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5170      &  +x(40)*xx*zz
5171         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5172         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5173      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5174      &  +x(59)*zz**2 +x(60)*xx*zz
5175         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5176      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5177      &        +(pom1-pom2)*pom_dy
5178 #ifdef DEBUG
5179         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5180 #endif
5181 C
5182         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5183      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5184      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5185      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5186      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5187      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5188      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5189      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5190 #ifdef DEBUG
5191         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5192 #endif
5193 C
5194         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5195      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5196      &  +pom1*pom_dt1+pom2*pom_dt2
5197 #ifdef DEBUG
5198         write(2,*), "de_dt = ", de_dt,de_dt_num
5199 #endif
5200 c
5201 C
5202        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5203        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5204        cosfac2xx=cosfac2*xx
5205        sinfac2yy=sinfac2*yy
5206        do k = 1,3
5207          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5208      &      vbld_inv(i+1)
5209          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5210      &      vbld_inv(i)
5211          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5212          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5213 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5214 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5215 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5216 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5217          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5218          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5219          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5220          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5221          dZZ_Ci1(k)=0.0d0
5222          dZZ_Ci(k)=0.0d0
5223          do j=1,3
5224            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5225      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5226            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5227      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5228          enddo
5229
5230          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5231          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5232          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5233 c
5234          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5235          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5236        enddo
5237
5238        do k=1,3
5239          dXX_Ctab(k,i)=dXX_Ci(k)
5240          dXX_C1tab(k,i)=dXX_Ci1(k)
5241          dYY_Ctab(k,i)=dYY_Ci(k)
5242          dYY_C1tab(k,i)=dYY_Ci1(k)
5243          dZZ_Ctab(k,i)=dZZ_Ci(k)
5244          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5245          dXX_XYZtab(k,i)=dXX_XYZ(k)
5246          dYY_XYZtab(k,i)=dYY_XYZ(k)
5247          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5248        enddo
5249
5250        do k = 1,3
5251 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5252 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5253 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5254 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5255 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5256 c     &    dt_dci(k)
5257 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5258 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5259          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5260      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5261          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5262      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5263          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5264      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5265        enddo
5266 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5267 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5268
5269 C to check gradient call subroutine check_grad
5270
5271     1 continue
5272       enddo
5273       return
5274       end
5275 #endif
5276 c------------------------------------------------------------------------------
5277       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5278 C
5279 C This procedure calculates two-body contact function g(rij) and its derivative:
5280 C
5281 C           eps0ij                                     !       x < -1
5282 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5283 C            0                                         !       x > 1
5284 C
5285 C where x=(rij-r0ij)/delta
5286 C
5287 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5288 C
5289       implicit none
5290       double precision rij,r0ij,eps0ij,fcont,fprimcont
5291       double precision x,x2,x4,delta
5292 c     delta=0.02D0*r0ij
5293 c      delta=0.2D0*r0ij
5294       x=(rij-r0ij)/delta
5295       if (x.lt.-1.0D0) then
5296         fcont=eps0ij
5297         fprimcont=0.0D0
5298       else if (x.le.1.0D0) then
5299         x2=x*x
5300         x4=x2*x2
5301         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5302         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5303       else
5304         fcont=0.0D0
5305         fprimcont=0.0D0
5306       endif
5307       return
5308       end
5309 c------------------------------------------------------------------------------
5310       subroutine splinthet(theti,delta,ss,ssder)
5311       implicit real*8 (a-h,o-z)
5312       include 'DIMENSIONS'
5313       include 'DIMENSIONS.ZSCOPT'
5314       include 'COMMON.VAR'
5315       include 'COMMON.GEO'
5316       thetup=pi-delta
5317       thetlow=delta
5318       if (theti.gt.pipol) then
5319         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5320       else
5321         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5322         ssder=-ssder
5323       endif
5324       return
5325       end
5326 c------------------------------------------------------------------------------
5327       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5328       implicit none
5329       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5330       double precision ksi,ksi2,ksi3,a1,a2,a3
5331       a1=fprim0*delta/(f1-f0)
5332       a2=3.0d0-2.0d0*a1
5333       a3=a1-2.0d0
5334       ksi=(x-x0)/delta
5335       ksi2=ksi*ksi
5336       ksi3=ksi2*ksi
5337       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5338       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5339       return
5340       end
5341 c------------------------------------------------------------------------------
5342       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5343       implicit none
5344       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5345       double precision ksi,ksi2,ksi3,a1,a2,a3
5346       ksi=(x-x0)/delta
5347       ksi2=ksi*ksi
5348       ksi3=ksi2*ksi
5349       a1=fprim0x*delta
5350       a2=3*(f1x-f0x)-2*fprim0x*delta
5351       a3=fprim0x*delta-2*(f1x-f0x)
5352       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5353       return
5354       end
5355 C-----------------------------------------------------------------------------
5356 #ifdef CRYST_TOR
5357 C-----------------------------------------------------------------------------
5358       subroutine etor(etors,edihcnstr,fact)
5359       implicit real*8 (a-h,o-z)
5360       include 'DIMENSIONS'
5361       include 'DIMENSIONS.ZSCOPT'
5362       include 'COMMON.VAR'
5363       include 'COMMON.GEO'
5364       include 'COMMON.LOCAL'
5365       include 'COMMON.TORSION'
5366       include 'COMMON.INTERACT'
5367       include 'COMMON.DERIV'
5368       include 'COMMON.CHAIN'
5369       include 'COMMON.NAMES'
5370       include 'COMMON.IOUNITS'
5371       include 'COMMON.FFIELD'
5372       include 'COMMON.TORCNSTR'
5373       logical lprn
5374 C Set lprn=.true. for debugging
5375       lprn=.false.
5376 c      lprn=.true.
5377       etors=0.0D0
5378       do i=iphi_start,iphi_end
5379         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5380      &      .or. itype(i).eq.ntyp1) cycle
5381         itori=itortyp(itype(i-2))
5382         itori1=itortyp(itype(i-1))
5383         phii=phi(i)
5384         gloci=0.0D0
5385 C Proline-Proline pair is a special case...
5386         if (itori.eq.3 .and. itori1.eq.3) then
5387           if (phii.gt.-dwapi3) then
5388             cosphi=dcos(3*phii)
5389             fac=1.0D0/(1.0D0-cosphi)
5390             etorsi=v1(1,3,3)*fac
5391             etorsi=etorsi+etorsi
5392             etors=etors+etorsi-v1(1,3,3)
5393             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5394           endif
5395           do j=1,3
5396             v1ij=v1(j+1,itori,itori1)
5397             v2ij=v2(j+1,itori,itori1)
5398             cosphi=dcos(j*phii)
5399             sinphi=dsin(j*phii)
5400             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5401             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5402           enddo
5403         else
5404           do j=1,nterm_old
5405             v1ij=v1(j,itori,itori1)
5406             v2ij=v2(j,itori,itori1)
5407             cosphi=dcos(j*phii)
5408             sinphi=dsin(j*phii)
5409             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5410             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5411           enddo
5412         endif
5413         if (lprn)
5414      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5415      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5416      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5417         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5418 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5419       enddo
5420 ! 6/20/98 - dihedral angle constraints
5421       edihcnstr=0.0d0
5422       do i=1,ndih_constr
5423         itori=idih_constr(i)
5424         phii=phi(itori)
5425         difi=phii-phi0(i)
5426         if (difi.gt.drange(i)) then
5427           difi=difi-drange(i)
5428           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5429           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5430         else if (difi.lt.-drange(i)) then
5431           difi=difi+drange(i)
5432           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5433           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5434         endif
5435 C        write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5436 C     &    i,itori,rad2deg*phii,
5437 C     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5438       enddo
5439 !      write (iout,*) 'edihcnstr',edihcnstr
5440       return
5441       end
5442 c------------------------------------------------------------------------------
5443 #else
5444       subroutine etor(etors,edihcnstr,fact)
5445       implicit real*8 (a-h,o-z)
5446       include 'DIMENSIONS'
5447       include 'DIMENSIONS.ZSCOPT'
5448       include 'COMMON.VAR'
5449       include 'COMMON.GEO'
5450       include 'COMMON.LOCAL'
5451       include 'COMMON.TORSION'
5452       include 'COMMON.INTERACT'
5453       include 'COMMON.DERIV'
5454       include 'COMMON.CHAIN'
5455       include 'COMMON.NAMES'
5456       include 'COMMON.IOUNITS'
5457       include 'COMMON.FFIELD'
5458       include 'COMMON.TORCNSTR'
5459       logical lprn
5460 C Set lprn=.true. for debugging
5461       lprn=.false.
5462 c      lprn=.true.
5463       etors=0.0D0
5464       do i=iphi_start,iphi_end
5465         if (i.le.2) cycle
5466         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5467      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5468 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5469 C     &       .or. itype(i).eq.ntyp1) cycle
5470         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5471          if (iabs(itype(i)).eq.20) then
5472          iblock=2
5473          else
5474          iblock=1
5475          endif
5476         itori=itortyp(itype(i-2))
5477         itori1=itortyp(itype(i-1))
5478         phii=phi(i)
5479         gloci=0.0D0
5480 C Regular cosine and sine terms
5481         do j=1,nterm(itori,itori1,iblock)
5482           v1ij=v1(j,itori,itori1,iblock)
5483           v2ij=v2(j,itori,itori1,iblock)
5484           cosphi=dcos(j*phii)
5485           sinphi=dsin(j*phii)
5486           etors=etors+v1ij*cosphi+v2ij*sinphi
5487           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5488         enddo
5489 C Lorentz terms
5490 C                         v1
5491 C  E = SUM ----------------------------------- - v1
5492 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5493 C
5494         cosphi=dcos(0.5d0*phii)
5495         sinphi=dsin(0.5d0*phii)
5496         do j=1,nlor(itori,itori1,iblock)
5497           vl1ij=vlor1(j,itori,itori1)
5498           vl2ij=vlor2(j,itori,itori1)
5499           vl3ij=vlor3(j,itori,itori1)
5500           pom=vl2ij*cosphi+vl3ij*sinphi
5501           pom1=1.0d0/(pom*pom+1.0d0)
5502           etors=etors+vl1ij*pom1
5503 c          if (energy_dec) etors_ii=etors_ii+
5504 c     &                vl1ij*pom1
5505           pom=-pom*pom1*pom1
5506           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5507         enddo
5508 C Subtract the constant term
5509         etors=etors-v0(itori,itori1,iblock)
5510         if (lprn)
5511      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5512      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5513      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5514         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5515 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5516  1215   continue
5517       enddo
5518 ! 6/20/98 - dihedral angle constraints
5519       edihcnstr=0.0d0
5520       do i=1,ndih_constr
5521         itori=idih_constr(i)
5522         phii=phi(itori)
5523         difi=pinorm(phii-phi0(i))
5524         edihi=0.0d0
5525         if (difi.gt.drange(i)) then
5526           difi=difi-drange(i)
5527           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5528           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5529           edihi=0.25d0*ftors(i)*difi**4
5530         else if (difi.lt.-drange(i)) then
5531           difi=difi+drange(i)
5532           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5533           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5534           edihi=0.25d0*ftors(i)*difi**4
5535         else
5536           difi=0.0d0
5537         endif
5538         write (iout,'(a6,2i5,2f8.3,2e14.5)') "edih",
5539      &    i,itori,rad2deg*phii,
5540      &    rad2deg*difi,0.25d0*ftors(i)*difi**4
5541 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
5542 c     &    drange(i),edihi
5543 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5544 !     &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5545       enddo
5546 !      write (iout,*) 'edihcnstr',edihcnstr
5547       return
5548       end
5549 c----------------------------------------------------------------------------
5550       subroutine etor_d(etors_d,fact2)
5551 C 6/23/01 Compute double torsional energy
5552       implicit real*8 (a-h,o-z)
5553       include 'DIMENSIONS'
5554       include 'DIMENSIONS.ZSCOPT'
5555       include 'COMMON.VAR'
5556       include 'COMMON.GEO'
5557       include 'COMMON.LOCAL'
5558       include 'COMMON.TORSION'
5559       include 'COMMON.INTERACT'
5560       include 'COMMON.DERIV'
5561       include 'COMMON.CHAIN'
5562       include 'COMMON.NAMES'
5563       include 'COMMON.IOUNITS'
5564       include 'COMMON.FFIELD'
5565       include 'COMMON.TORCNSTR'
5566       logical lprn
5567 C Set lprn=.true. for debugging
5568       lprn=.false.
5569 c     lprn=.true.
5570       etors_d=0.0D0
5571       do i=iphi_start,iphi_end-1
5572         if (i.le.3) cycle
5573 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5574 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5575          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5576      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5577      &  (itype(i+1).eq.ntyp1)) cycle
5578         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5579      &     goto 1215
5580         itori=itortyp(itype(i-2))
5581         itori1=itortyp(itype(i-1))
5582         itori2=itortyp(itype(i))
5583         phii=phi(i)
5584         phii1=phi(i+1)
5585         gloci1=0.0D0
5586         gloci2=0.0D0
5587         iblock=1
5588         if (iabs(itype(i+1)).eq.20) iblock=2
5589 C Regular cosine and sine terms
5590         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5591           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5592           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5593           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5594           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5595           cosphi1=dcos(j*phii)
5596           sinphi1=dsin(j*phii)
5597           cosphi2=dcos(j*phii1)
5598           sinphi2=dsin(j*phii1)
5599           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5600      &     v2cij*cosphi2+v2sij*sinphi2
5601           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5602           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5603         enddo
5604         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5605           do l=1,k-1
5606             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5607             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5608             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5609             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5610             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5611             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5612             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5613             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5614             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5615      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5616             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5617      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5618             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5619      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5620           enddo
5621         enddo
5622         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5623         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5624  1215   continue
5625       enddo
5626       return
5627       end
5628 #endif
5629 c------------------------------------------------------------------------------
5630       subroutine eback_sc_corr(esccor)
5631 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5632 c        conformational states; temporarily implemented as differences
5633 c        between UNRES torsional potentials (dependent on three types of
5634 c        residues) and the torsional potentials dependent on all 20 types
5635 c        of residues computed from AM1 energy surfaces of terminally-blocked
5636 c        amino-acid residues.
5637       implicit real*8 (a-h,o-z)
5638       include 'DIMENSIONS'
5639       include 'DIMENSIONS.ZSCOPT'
5640       include 'DIMENSIONS.FREE'
5641       include 'COMMON.VAR'
5642       include 'COMMON.GEO'
5643       include 'COMMON.LOCAL'
5644       include 'COMMON.TORSION'
5645       include 'COMMON.SCCOR'
5646       include 'COMMON.INTERACT'
5647       include 'COMMON.DERIV'
5648       include 'COMMON.CHAIN'
5649       include 'COMMON.NAMES'
5650       include 'COMMON.IOUNITS'
5651       include 'COMMON.FFIELD'
5652       include 'COMMON.CONTROL'
5653       logical lprn
5654 C Set lprn=.true. for debugging
5655       lprn=.false.
5656 c      lprn=.true.
5657 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
5658       esccor=0.0D0
5659       do i=itau_start,itau_end
5660         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5661         esccor_ii=0.0D0
5662         isccori=isccortyp(itype(i-2))
5663         isccori1=isccortyp(itype(i-1))
5664         phii=phi(i)
5665         do intertyp=1,3 !intertyp
5666 cc Added 09 May 2012 (Adasko)
5667 cc  Intertyp means interaction type of backbone mainchain correlation:
5668 c   1 = SC...Ca...Ca...Ca
5669 c   2 = Ca...Ca...Ca...SC
5670 c   3 = SC...Ca...Ca...SCi
5671         gloci=0.0D0
5672         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5673      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5674      &      (itype(i-1).eq.ntyp1)))
5675      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5676      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5677      &     .or.(itype(i).eq.ntyp1)))
5678      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5679      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5680      &      (itype(i-3).eq.ntyp1)))) cycle
5681         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5682         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5683      & cycle
5684        do j=1,nterm_sccor(isccori,isccori1)
5685           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5686           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5687           cosphi=dcos(j*tauangle(intertyp,i))
5688           sinphi=dsin(j*tauangle(intertyp,i))
5689            esccor=esccor+v1ij*cosphi+v2ij*sinphi
5690            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5691          enddo
5692 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
5693 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
5694 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5695         if (lprn)
5696      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5697      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5698      &  (v1sccor(j,1,itori,itori1),j=1,6)
5699      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
5700 c        gsccor_loc(i-3)=gloci
5701        enddo !intertyp
5702       enddo
5703       return
5704       end
5705 c------------------------------------------------------------------------------
5706       subroutine multibody(ecorr)
5707 C This subroutine calculates multi-body contributions to energy following
5708 C the idea of Skolnick et al. If side chains I and J make a contact and
5709 C at the same time side chains I+1 and J+1 make a contact, an extra
5710 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
5711       implicit real*8 (a-h,o-z)
5712       include 'DIMENSIONS'
5713       include 'COMMON.IOUNITS'
5714       include 'COMMON.DERIV'
5715       include 'COMMON.INTERACT'
5716       include 'COMMON.CONTACTS'
5717       double precision gx(3),gx1(3)
5718       logical lprn
5719
5720 C Set lprn=.true. for debugging
5721       lprn=.false.
5722
5723       if (lprn) then
5724         write (iout,'(a)') 'Contact function values:'
5725         do i=nnt,nct-2
5726           write (iout,'(i2,20(1x,i2,f10.5))')
5727      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
5728         enddo
5729       endif
5730       ecorr=0.0D0
5731       do i=nnt,nct
5732         do j=1,3
5733           gradcorr(j,i)=0.0D0
5734           gradxorr(j,i)=0.0D0
5735         enddo
5736       enddo
5737       do i=nnt,nct-2
5738
5739         DO ISHIFT = 3,4
5740
5741         i1=i+ishift
5742         num_conti=num_cont(i)
5743         num_conti1=num_cont(i1)
5744         do jj=1,num_conti
5745           j=jcont(jj,i)
5746           do kk=1,num_conti1
5747             j1=jcont(kk,i1)
5748             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
5749 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
5750 cd   &                   ' ishift=',ishift
5751 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
5752 C The system gains extra energy.
5753               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
5754             endif   ! j1==j+-ishift
5755           enddo     ! kk
5756         enddo       ! jj
5757
5758         ENDDO ! ISHIFT
5759
5760       enddo         ! i
5761       return
5762       end
5763 c------------------------------------------------------------------------------
5764       double precision function esccorr(i,j,k,l,jj,kk)
5765       implicit real*8 (a-h,o-z)
5766       include 'DIMENSIONS'
5767       include 'COMMON.IOUNITS'
5768       include 'COMMON.DERIV'
5769       include 'COMMON.INTERACT'
5770       include 'COMMON.CONTACTS'
5771       double precision gx(3),gx1(3)
5772       logical lprn
5773       lprn=.false.
5774       eij=facont(jj,i)
5775       ekl=facont(kk,k)
5776 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
5777 C Calculate the multi-body contribution to energy.
5778 C Calculate multi-body contributions to the gradient.
5779 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
5780 cd   & k,l,(gacont(m,kk,k),m=1,3)
5781       do m=1,3
5782         gx(m) =ekl*gacont(m,jj,i)
5783         gx1(m)=eij*gacont(m,kk,k)
5784         gradxorr(m,i)=gradxorr(m,i)-gx(m)
5785         gradxorr(m,j)=gradxorr(m,j)+gx(m)
5786         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
5787         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
5788       enddo
5789       do m=i,j-1
5790         do ll=1,3
5791           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
5792         enddo
5793       enddo
5794       do m=k,l-1
5795         do ll=1,3
5796           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
5797         enddo
5798       enddo
5799       esccorr=-eij*ekl
5800       return
5801       end
5802 c------------------------------------------------------------------------------
5803 #ifdef MPL
5804       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
5805       implicit real*8 (a-h,o-z)
5806       include 'DIMENSIONS'
5807       integer dimen1,dimen2,atom,indx
5808       double precision buffer(dimen1,dimen2)
5809       double precision zapas
5810       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5811      &   facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
5812      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5813       num_kont=num_cont_hb(atom)
5814       do i=1,num_kont
5815         do k=1,7
5816           do j=1,3
5817             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
5818           enddo ! j
5819         enddo ! k
5820         buffer(i,indx+22)=facont_hb(i,atom)
5821         buffer(i,indx+23)=ees0p(i,atom)
5822         buffer(i,indx+24)=ees0m(i,atom)
5823         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
5824       enddo ! i
5825       buffer(1,indx+26)=dfloat(num_kont)
5826       return
5827       end
5828 c------------------------------------------------------------------------------
5829       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
5830       implicit real*8 (a-h,o-z)
5831       include 'DIMENSIONS'
5832       integer dimen1,dimen2,atom,indx
5833       double precision buffer(dimen1,dimen2)
5834       double precision zapas
5835       common /contacts_hb/ zapas(3,ntyp,maxres,7),
5836      &         facont_hb(ntyp,maxres),ees0p(ntyp,maxres),
5837      &         ees0m(ntyp,maxres),
5838      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
5839       num_kont=buffer(1,indx+26)
5840       num_kont_old=num_cont_hb(atom)
5841       num_cont_hb(atom)=num_kont+num_kont_old
5842       do i=1,num_kont
5843         ii=i+num_kont_old
5844         do k=1,7
5845           do j=1,3
5846             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
5847           enddo ! j
5848         enddo ! k
5849         facont_hb(ii,atom)=buffer(i,indx+22)
5850         ees0p(ii,atom)=buffer(i,indx+23)
5851         ees0m(ii,atom)=buffer(i,indx+24)
5852         jcont_hb(ii,atom)=buffer(i,indx+25)
5853       enddo ! i
5854       return
5855       end
5856 c------------------------------------------------------------------------------
5857 #endif
5858       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
5859 C This subroutine calculates multi-body contributions to hydrogen-bonding
5860       implicit real*8 (a-h,o-z)
5861       include 'DIMENSIONS'
5862       include 'DIMENSIONS.ZSCOPT'
5863       include 'COMMON.IOUNITS'
5864 #ifdef MPL
5865       include 'COMMON.INFO'
5866 #endif
5867       include 'COMMON.FFIELD'
5868       include 'COMMON.DERIV'
5869       include 'COMMON.INTERACT'
5870       include 'COMMON.CONTACTS'
5871 #ifdef MPL
5872       parameter (max_cont=maxconts)
5873       parameter (max_dim=2*(8*3+2))
5874       parameter (msglen1=max_cont*max_dim*4)
5875       parameter (msglen2=2*msglen1)
5876       integer source,CorrelType,CorrelID,Error
5877       double precision buffer(max_cont,max_dim)
5878 #endif
5879       double precision gx(3),gx1(3)
5880       logical lprn,ldone
5881
5882 C Set lprn=.true. for debugging
5883       lprn=.false.
5884 #ifdef MPL
5885       n_corr=0
5886       n_corr1=0
5887       if (fgProcs.le.1) goto 30
5888       if (lprn) then
5889         write (iout,'(a)') 'Contact function values:'
5890         do i=nnt,nct-2
5891           write (iout,'(2i3,50(1x,i2,f5.2))')
5892      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5893      &    j=1,num_cont_hb(i))
5894         enddo
5895       endif
5896 C Caution! Following code assumes that electrostatic interactions concerning
5897 C a given atom are split among at most two processors!
5898       CorrelType=477
5899       CorrelID=MyID+1
5900       ldone=.false.
5901       do i=1,max_cont
5902         do j=1,max_dim
5903           buffer(i,j)=0.0D0
5904         enddo
5905       enddo
5906       mm=mod(MyRank,2)
5907 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
5908       if (mm) 20,20,10
5909    10 continue
5910 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
5911       if (MyRank.gt.0) then
5912 C Send correlation contributions to the preceding processor
5913         msglen=msglen1
5914         nn=num_cont_hb(iatel_s)
5915         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
5916 cd      write (iout,*) 'The BUFFER array:'
5917 cd      do i=1,nn
5918 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
5919 cd      enddo
5920         if (ielstart(iatel_s).gt.iatel_s+ispp) then
5921           msglen=msglen2
5922             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
5923 C Clear the contacts of the atom passed to the neighboring processor
5924         nn=num_cont_hb(iatel_s+1)
5925 cd      do i=1,nn
5926 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
5927 cd      enddo
5928             num_cont_hb(iatel_s)=0
5929         endif
5930 cd      write (iout,*) 'Processor ',MyID,MyRank,
5931 cd   & ' is sending correlation contribution to processor',MyID-1,
5932 cd   & ' msglen=',msglen
5933 cd      write (*,*) 'Processor ',MyID,MyRank,
5934 cd   & ' is sending correlation contribution to processor',MyID-1,
5935 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5936         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
5937 cd      write (iout,*) 'Processor ',MyID,
5938 cd   & ' has sent correlation contribution to processor',MyID-1,
5939 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5940 cd      write (*,*) 'Processor ',MyID,
5941 cd   & ' has sent correlation contribution to processor',MyID-1,
5942 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
5943         msglen=msglen1
5944       endif ! (MyRank.gt.0)
5945       if (ldone) goto 30
5946       ldone=.true.
5947    20 continue
5948 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
5949       if (MyRank.lt.fgProcs-1) then
5950 C Receive correlation contributions from the next processor
5951         msglen=msglen1
5952         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
5953 cd      write (iout,*) 'Processor',MyID,
5954 cd   & ' is receiving correlation contribution from processor',MyID+1,
5955 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5956 cd      write (*,*) 'Processor',MyID,
5957 cd   & ' is receiving correlation contribution from processor',MyID+1,
5958 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
5959         nbytes=-1
5960         do while (nbytes.le.0)
5961           call mp_probe(MyID+1,CorrelType,nbytes)
5962         enddo
5963 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
5964         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
5965 cd      write (iout,*) 'Processor',MyID,
5966 cd   & ' has received correlation contribution from processor',MyID+1,
5967 cd   & ' msglen=',msglen,' nbytes=',nbytes
5968 cd      write (iout,*) 'The received BUFFER array:'
5969 cd      do i=1,max_cont
5970 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
5971 cd      enddo
5972         if (msglen.eq.msglen1) then
5973           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
5974         else if (msglen.eq.msglen2)  then
5975           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
5976           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
5977         else
5978           write (iout,*)
5979      & 'ERROR!!!! message length changed while processing correlations.'
5980           write (*,*)
5981      & 'ERROR!!!! message length changed while processing correlations.'
5982           call mp_stopall(Error)
5983         endif ! msglen.eq.msglen1
5984       endif ! MyRank.lt.fgProcs-1
5985       if (ldone) goto 30
5986       ldone=.true.
5987       goto 10
5988    30 continue
5989 #endif
5990       if (lprn) then
5991         write (iout,'(a)') 'Contact function values:'
5992         do i=nnt,nct-2
5993           write (iout,'(2i3,50(1x,i2,f5.2))')
5994      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
5995      &    j=1,num_cont_hb(i))
5996         enddo
5997       endif
5998       ecorr=0.0D0
5999 C Remove the loop below after debugging !!!
6000       do i=nnt,nct
6001         do j=1,3
6002           gradcorr(j,i)=0.0D0
6003           gradxorr(j,i)=0.0D0
6004         enddo
6005       enddo
6006 C Calculate the local-electrostatic correlation terms
6007       do i=iatel_s,iatel_e+1
6008         i1=i+1
6009         num_conti=num_cont_hb(i)
6010         num_conti1=num_cont_hb(i+1)
6011         do jj=1,num_conti
6012           j=jcont_hb(jj,i)
6013           do kk=1,num_conti1
6014             j1=jcont_hb(kk,i1)
6015 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6016 c     &         ' jj=',jj,' kk=',kk
6017             if (j1.eq.j+1 .or. j1.eq.j-1) then
6018 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6019 C The system gains extra energy.
6020               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6021               n_corr=n_corr+1
6022             else if (j1.eq.j) then
6023 C Contacts I-J and I-(J+1) occur simultaneously.
6024 C The system loses extra energy.
6025 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6026             endif
6027           enddo ! kk
6028           do kk=1,num_conti
6029             j1=jcont_hb(kk,i)
6030 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6031 c    &         ' jj=',jj,' kk=',kk
6032             if (j1.eq.j+1) then
6033 C Contacts I-J and (I+1)-J occur simultaneously.
6034 C The system loses extra energy.
6035 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6036             endif ! j1==j+1
6037           enddo ! kk
6038         enddo ! jj
6039       enddo ! i
6040       return
6041       end
6042 c------------------------------------------------------------------------------
6043       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6044      &  n_corr1)
6045 C This subroutine calculates multi-body contributions to hydrogen-bonding
6046       implicit real*8 (a-h,o-z)
6047       include 'DIMENSIONS'
6048       include 'DIMENSIONS.ZSCOPT'
6049       include 'COMMON.IOUNITS'
6050 #ifdef MPL
6051       include 'COMMON.INFO'
6052 #endif
6053       include 'COMMON.FFIELD'
6054       include 'COMMON.DERIV'
6055       include 'COMMON.INTERACT'
6056       include 'COMMON.CONTACTS'
6057 #ifdef MPL
6058       parameter (max_cont=maxconts)
6059       parameter (max_dim=2*(8*3+2))
6060       parameter (msglen1=max_cont*max_dim*4)
6061       parameter (msglen2=2*msglen1)
6062       integer source,CorrelType,CorrelID,Error
6063       double precision buffer(max_cont,max_dim)
6064 #endif
6065       double precision gx(3),gx1(3)
6066       logical lprn,ldone
6067
6068 C Set lprn=.true. for debugging
6069       lprn=.false.
6070       eturn6=0.0d0
6071       ecorr6=0.0d0
6072 #ifdef MPL
6073       n_corr=0
6074       n_corr1=0
6075       if (fgProcs.le.1) goto 30
6076       if (lprn) then
6077         write (iout,'(a)') 'Contact function values:'
6078         do i=nnt,nct-2
6079           write (iout,'(2i3,50(1x,i2,f5.2))')
6080      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6081      &    j=1,num_cont_hb(i))
6082         enddo
6083       endif
6084 C Caution! Following code assumes that electrostatic interactions concerning
6085 C a given atom are split among at most two processors!
6086       CorrelType=477
6087       CorrelID=MyID+1
6088       ldone=.false.
6089       do i=1,max_cont
6090         do j=1,max_dim
6091           buffer(i,j)=0.0D0
6092         enddo
6093       enddo
6094       mm=mod(MyRank,2)
6095 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6096       if (mm) 20,20,10
6097    10 continue
6098 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6099       if (MyRank.gt.0) then
6100 C Send correlation contributions to the preceding processor
6101         msglen=msglen1
6102         nn=num_cont_hb(iatel_s)
6103         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6104 cd      write (iout,*) 'The BUFFER array:'
6105 cd      do i=1,nn
6106 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6107 cd      enddo
6108         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6109           msglen=msglen2
6110             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6111 C Clear the contacts of the atom passed to the neighboring processor
6112         nn=num_cont_hb(iatel_s+1)
6113 cd      do i=1,nn
6114 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6115 cd      enddo
6116             num_cont_hb(iatel_s)=0
6117         endif
6118 cd      write (iout,*) 'Processor ',MyID,MyRank,
6119 cd   & ' is sending correlation contribution to processor',MyID-1,
6120 cd   & ' msglen=',msglen
6121 cd      write (*,*) 'Processor ',MyID,MyRank,
6122 cd   & ' is sending correlation contribution to processor',MyID-1,
6123 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6124         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6125 cd      write (iout,*) 'Processor ',MyID,
6126 cd   & ' has sent correlation contribution to processor',MyID-1,
6127 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6128 cd      write (*,*) 'Processor ',MyID,
6129 cd   & ' has sent correlation contribution to processor',MyID-1,
6130 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6131         msglen=msglen1
6132       endif ! (MyRank.gt.0)
6133       if (ldone) goto 30
6134       ldone=.true.
6135    20 continue
6136 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6137       if (MyRank.lt.fgProcs-1) then
6138 C Receive correlation contributions from the next processor
6139         msglen=msglen1
6140         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6141 cd      write (iout,*) 'Processor',MyID,
6142 cd   & ' is receiving correlation contribution from processor',MyID+1,
6143 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6144 cd      write (*,*) 'Processor',MyID,
6145 cd   & ' is receiving correlation contribution from processor',MyID+1,
6146 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6147         nbytes=-1
6148         do while (nbytes.le.0)
6149           call mp_probe(MyID+1,CorrelType,nbytes)
6150         enddo
6151 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6152         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6153 cd      write (iout,*) 'Processor',MyID,
6154 cd   & ' has received correlation contribution from processor',MyID+1,
6155 cd   & ' msglen=',msglen,' nbytes=',nbytes
6156 cd      write (iout,*) 'The received BUFFER array:'
6157 cd      do i=1,max_cont
6158 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6159 cd      enddo
6160         if (msglen.eq.msglen1) then
6161           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6162         else if (msglen.eq.msglen2)  then
6163           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6164           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6165         else
6166           write (iout,*)
6167      & 'ERROR!!!! message length changed while processing correlations.'
6168           write (*,*)
6169      & 'ERROR!!!! message length changed while processing correlations.'
6170           call mp_stopall(Error)
6171         endif ! msglen.eq.msglen1
6172       endif ! MyRank.lt.fgProcs-1
6173       if (ldone) goto 30
6174       ldone=.true.
6175       goto 10
6176    30 continue
6177 #endif
6178       if (lprn) then
6179         write (iout,'(a)') 'Contact function values:'
6180         do i=nnt,nct-2
6181           write (iout,'(2i3,50(1x,i2,f5.2))')
6182      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6183      &    j=1,num_cont_hb(i))
6184         enddo
6185       endif
6186       ecorr=0.0D0
6187       ecorr5=0.0d0
6188       ecorr6=0.0d0
6189 C Remove the loop below after debugging !!!
6190       do i=nnt,nct
6191         do j=1,3
6192           gradcorr(j,i)=0.0D0
6193           gradxorr(j,i)=0.0D0
6194         enddo
6195       enddo
6196 C Calculate the dipole-dipole interaction energies
6197       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6198       do i=iatel_s,iatel_e+1
6199         num_conti=num_cont_hb(i)
6200         do jj=1,num_conti
6201           j=jcont_hb(jj,i)
6202           call dipole(i,j,jj)
6203         enddo
6204       enddo
6205       endif
6206 C Calculate the local-electrostatic correlation terms
6207       do i=iatel_s,iatel_e+1
6208         i1=i+1
6209         num_conti=num_cont_hb(i)
6210         num_conti1=num_cont_hb(i+1)
6211         do jj=1,num_conti
6212           j=jcont_hb(jj,i)
6213           do kk=1,num_conti1
6214             j1=jcont_hb(kk,i1)
6215 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6216 c     &         ' jj=',jj,' kk=',kk
6217             if (j1.eq.j+1 .or. j1.eq.j-1) then
6218 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6219 C The system gains extra energy.
6220               n_corr=n_corr+1
6221               sqd1=dsqrt(d_cont(jj,i))
6222               sqd2=dsqrt(d_cont(kk,i1))
6223               sred_geom = sqd1*sqd2
6224               IF (sred_geom.lt.cutoff_corr) THEN
6225                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6226      &            ekont,fprimcont)
6227 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6228 c     &         ' jj=',jj,' kk=',kk
6229                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6230                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6231                 do l=1,3
6232                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6233                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6234                 enddo
6235                 n_corr1=n_corr1+1
6236 cd               write (iout,*) 'sred_geom=',sred_geom,
6237 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6238                 call calc_eello(i,j,i+1,j1,jj,kk)
6239                 if (wcorr4.gt.0.0d0)
6240      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6241                 if (wcorr5.gt.0.0d0)
6242      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6243 c                print *,"wcorr5",ecorr5
6244 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6245 cd                write(2,*)'ijkl',i,j,i+1,j1
6246                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6247      &               .or. wturn6.eq.0.0d0))then
6248 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6249                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6250 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6251 cd     &            'ecorr6=',ecorr6
6252 cd                write (iout,'(4e15.5)') sred_geom,
6253 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6254 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6255 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6256                 else if (wturn6.gt.0.0d0
6257      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6258 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6259                   eturn6=eturn6+eello_turn6(i,jj,kk)
6260 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6261                  else if ((wturn6.eq.0.0d0).and.(wcorr6.eq.0.0d0)) then
6262                    eturn6=0.0d0
6263                    ecorr6=0.0d0
6264                 endif
6265
6266               ENDIF
6267 1111          continue
6268             else if (j1.eq.j) then
6269 C Contacts I-J and I-(J+1) occur simultaneously.
6270 C The system loses extra energy.
6271 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6272             endif
6273           enddo ! kk
6274           do kk=1,num_conti
6275             j1=jcont_hb(kk,i)
6276 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6277 c    &         ' jj=',jj,' kk=',kk
6278             if (j1.eq.j+1) then
6279 C Contacts I-J and (I+1)-J occur simultaneously.
6280 C The system loses extra energy.
6281 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6282             endif ! j1==j+1
6283           enddo ! kk
6284         enddo ! jj
6285       enddo ! i
6286       write (iout,*) "eturn6",eturn6,ecorr6
6287       return
6288       end
6289 c------------------------------------------------------------------------------
6290       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6291       implicit real*8 (a-h,o-z)
6292       include 'DIMENSIONS'
6293       include 'COMMON.IOUNITS'
6294       include 'COMMON.DERIV'
6295       include 'COMMON.INTERACT'
6296       include 'COMMON.CONTACTS'
6297       double precision gx(3),gx1(3)
6298       logical lprn
6299       lprn=.false.
6300       eij=facont_hb(jj,i)
6301       ekl=facont_hb(kk,k)
6302       ees0pij=ees0p(jj,i)
6303       ees0pkl=ees0p(kk,k)
6304       ees0mij=ees0m(jj,i)
6305       ees0mkl=ees0m(kk,k)
6306       ekont=eij*ekl
6307       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6308 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6309 C Following 4 lines for diagnostics.
6310 cd    ees0pkl=0.0D0
6311 cd    ees0pij=1.0D0
6312 cd    ees0mkl=0.0D0
6313 cd    ees0mij=1.0D0
6314 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6315 c    &   ' and',k,l
6316 c     write (iout,*)'Contacts have occurred for peptide groups',
6317 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6318 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6319 C Calculate the multi-body contribution to energy.
6320       ecorr=ecorr+ekont*ees
6321       if (calc_grad) then
6322 C Calculate multi-body contributions to the gradient.
6323       do ll=1,3
6324         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6325         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6326      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6327      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6328         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6329      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6330      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6331         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6332         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6333      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6334      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6335         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6336      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6337      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6338       enddo
6339       do m=i+1,j-1
6340         do ll=1,3
6341           gradcorr(ll,m)=gradcorr(ll,m)+
6342      &     ees*ekl*gacont_hbr(ll,jj,i)-
6343      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6344      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6345         enddo
6346       enddo
6347       do m=k+1,l-1
6348         do ll=1,3
6349           gradcorr(ll,m)=gradcorr(ll,m)+
6350      &     ees*eij*gacont_hbr(ll,kk,k)-
6351      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6352      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6353         enddo
6354       enddo
6355       endif
6356       ehbcorr=ekont*ees
6357       return
6358       end
6359 C---------------------------------------------------------------------------
6360       subroutine dipole(i,j,jj)
6361       implicit real*8 (a-h,o-z)
6362       include 'DIMENSIONS'
6363       include 'DIMENSIONS.ZSCOPT'
6364       include 'COMMON.IOUNITS'
6365       include 'COMMON.CHAIN'
6366       include 'COMMON.FFIELD'
6367       include 'COMMON.DERIV'
6368       include 'COMMON.INTERACT'
6369       include 'COMMON.CONTACTS'
6370       include 'COMMON.TORSION'
6371       include 'COMMON.VAR'
6372       include 'COMMON.GEO'
6373       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6374      &  auxmat(2,2)
6375       iti1 = itortyp(itype(i+1))
6376       if (j.lt.nres-1) then
6377         if (itype(j).le.ntyp) then
6378           itj1 = itortyp(itype(j+1))
6379         else
6380           itj=ntortyp+1
6381         endif
6382       else
6383         itj1=ntortyp+1
6384       endif
6385       do iii=1,2
6386         dipi(iii,1)=Ub2(iii,i)
6387         dipderi(iii)=Ub2der(iii,i)
6388         dipi(iii,2)=b1(iii,iti1)
6389         dipj(iii,1)=Ub2(iii,j)
6390         dipderj(iii)=Ub2der(iii,j)
6391         dipj(iii,2)=b1(iii,itj1)
6392       enddo
6393       kkk=0
6394       do iii=1,2
6395         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6396         do jjj=1,2
6397           kkk=kkk+1
6398           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6399         enddo
6400       enddo
6401       if (.not.calc_grad) return
6402       do kkk=1,5
6403         do lll=1,3
6404           mmm=0
6405           do iii=1,2
6406             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6407      &        auxvec(1))
6408             do jjj=1,2
6409               mmm=mmm+1
6410               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6411             enddo
6412           enddo
6413         enddo
6414       enddo
6415       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6416       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6417       do iii=1,2
6418         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6419       enddo
6420       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6421       do iii=1,2
6422         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6423       enddo
6424       return
6425       end
6426 C---------------------------------------------------------------------------
6427       subroutine calc_eello(i,j,k,l,jj,kk)
6428 C
6429 C This subroutine computes matrices and vectors needed to calculate
6430 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6431 C
6432       implicit real*8 (a-h,o-z)
6433       include 'DIMENSIONS'
6434       include 'DIMENSIONS.ZSCOPT'
6435       include 'COMMON.IOUNITS'
6436       include 'COMMON.CHAIN'
6437       include 'COMMON.DERIV'
6438       include 'COMMON.INTERACT'
6439       include 'COMMON.CONTACTS'
6440       include 'COMMON.TORSION'
6441       include 'COMMON.VAR'
6442       include 'COMMON.GEO'
6443       include 'COMMON.FFIELD'
6444       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6445      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6446       logical lprn
6447       common /kutas/ lprn
6448 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6449 cd     & ' jj=',jj,' kk=',kk
6450 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6451       do iii=1,2
6452         do jjj=1,2
6453           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6454           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6455         enddo
6456       enddo
6457       call transpose2(aa1(1,1),aa1t(1,1))
6458       call transpose2(aa2(1,1),aa2t(1,1))
6459       do kkk=1,5
6460         do lll=1,3
6461           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6462      &      aa1tder(1,1,lll,kkk))
6463           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6464      &      aa2tder(1,1,lll,kkk))
6465         enddo
6466       enddo
6467       if (l.eq.j+1) then
6468 C parallel orientation of the two CA-CA-CA frames.
6469         if (i.gt.1 .and. itype(i).le.ntyp) then
6470           iti=itortyp(itype(i))
6471         else
6472           iti=ntortyp+1
6473         endif
6474         itk1=itortyp(itype(k+1))
6475         itj=itortyp(itype(j))
6476         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
6477           itl1=itortyp(itype(l+1))
6478         else
6479           itl1=ntortyp+1
6480         endif
6481 C A1 kernel(j+1) A2T
6482 cd        do iii=1,2
6483 cd          write (iout,'(3f10.5,5x,3f10.5)')
6484 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6485 cd        enddo
6486         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6487      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6488      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6489 C Following matrices are needed only for 6-th order cumulants
6490         IF (wcorr6.gt.0.0d0) THEN
6491         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6492      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6493      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6494         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6495      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6496      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6497      &   ADtEAderx(1,1,1,1,1,1))
6498         lprn=.false.
6499         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6500      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6501      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6502      &   ADtEA1derx(1,1,1,1,1,1))
6503         ENDIF
6504 C End 6-th order cumulants
6505 cd        lprn=.false.
6506 cd        if (lprn) then
6507 cd        write (2,*) 'In calc_eello6'
6508 cd        do iii=1,2
6509 cd          write (2,*) 'iii=',iii
6510 cd          do kkk=1,5
6511 cd            write (2,*) 'kkk=',kkk
6512 cd            do jjj=1,2
6513 cd              write (2,'(3(2f10.5),5x)')
6514 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6515 cd            enddo
6516 cd          enddo
6517 cd        enddo
6518 cd        endif
6519         call transpose2(EUgder(1,1,k),auxmat(1,1))
6520         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6521         call transpose2(EUg(1,1,k),auxmat(1,1))
6522         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6523         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6524         do iii=1,2
6525           do kkk=1,5
6526             do lll=1,3
6527               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6528      &          EAEAderx(1,1,lll,kkk,iii,1))
6529             enddo
6530           enddo
6531         enddo
6532 C A1T kernel(i+1) A2
6533         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6534      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6535      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6536 C Following matrices are needed only for 6-th order cumulants
6537         IF (wcorr6.gt.0.0d0) THEN
6538         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6539      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6540      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6541         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6542      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6543      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6544      &   ADtEAderx(1,1,1,1,1,2))
6545         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6546      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6547      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6548      &   ADtEA1derx(1,1,1,1,1,2))
6549         ENDIF
6550 C End 6-th order cumulants
6551         call transpose2(EUgder(1,1,l),auxmat(1,1))
6552         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6553         call transpose2(EUg(1,1,l),auxmat(1,1))
6554         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6555         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6556         do iii=1,2
6557           do kkk=1,5
6558             do lll=1,3
6559               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6560      &          EAEAderx(1,1,lll,kkk,iii,2))
6561             enddo
6562           enddo
6563         enddo
6564 C AEAb1 and AEAb2
6565 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6566 C They are needed only when the fifth- or the sixth-order cumulants are
6567 C indluded.
6568         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6569         call transpose2(AEA(1,1,1),auxmat(1,1))
6570         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6571         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6572         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6573         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6574         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6575         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6576         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6577         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6578         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6579         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6580         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6581         call transpose2(AEA(1,1,2),auxmat(1,1))
6582         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
6583         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6584         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6585         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6586         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
6587         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6588         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
6589         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
6590         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6591         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6592         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6593 C Calculate the Cartesian derivatives of the vectors.
6594         do iii=1,2
6595           do kkk=1,5
6596             do lll=1,3
6597               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6598               call matvec2(auxmat(1,1),b1(1,iti),
6599      &          AEAb1derx(1,lll,kkk,iii,1,1))
6600               call matvec2(auxmat(1,1),Ub2(1,i),
6601      &          AEAb2derx(1,lll,kkk,iii,1,1))
6602               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6603      &          AEAb1derx(1,lll,kkk,iii,2,1))
6604               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6605      &          AEAb2derx(1,lll,kkk,iii,2,1))
6606               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6607               call matvec2(auxmat(1,1),b1(1,itj),
6608      &          AEAb1derx(1,lll,kkk,iii,1,2))
6609               call matvec2(auxmat(1,1),Ub2(1,j),
6610      &          AEAb2derx(1,lll,kkk,iii,1,2))
6611               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
6612      &          AEAb1derx(1,lll,kkk,iii,2,2))
6613               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
6614      &          AEAb2derx(1,lll,kkk,iii,2,2))
6615             enddo
6616           enddo
6617         enddo
6618         ENDIF
6619 C End vectors
6620       else
6621 C Antiparallel orientation of the two CA-CA-CA frames.
6622         if (i.gt.1 .and. itype(i).le.ntyp) then
6623           iti=itortyp(itype(i))
6624         else
6625           iti=ntortyp+1
6626         endif
6627         itk1=itortyp(itype(k+1))
6628         itl=itortyp(itype(l))
6629         itj=itortyp(itype(j))
6630         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
6631           itj1=itortyp(itype(j+1))
6632         else
6633           itj1=ntortyp+1
6634         endif
6635 C A2 kernel(j-1)T A1T
6636         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6637      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
6638      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6639 C Following matrices are needed only for 6-th order cumulants
6640         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6641      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6642         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6643      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
6644      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6645         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6646      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
6647      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6648      &   ADtEAderx(1,1,1,1,1,1))
6649         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6650      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
6651      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6652      &   ADtEA1derx(1,1,1,1,1,1))
6653         ENDIF
6654 C End 6-th order cumulants
6655         call transpose2(EUgder(1,1,k),auxmat(1,1))
6656         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6657         call transpose2(EUg(1,1,k),auxmat(1,1))
6658         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6659         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6660         do iii=1,2
6661           do kkk=1,5
6662             do lll=1,3
6663               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6664      &          EAEAderx(1,1,lll,kkk,iii,1))
6665             enddo
6666           enddo
6667         enddo
6668 C A2T kernel(i+1)T A1
6669         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6670      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
6671      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6672 C Following matrices are needed only for 6-th order cumulants
6673         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
6674      &     j.eq.i+4 .and. l.eq.i+3)) THEN
6675         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6676      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
6677      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6678         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6679      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
6680      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6681      &   ADtEAderx(1,1,1,1,1,2))
6682         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
6683      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
6684      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6685      &   ADtEA1derx(1,1,1,1,1,2))
6686         ENDIF
6687 C End 6-th order cumulants
6688         call transpose2(EUgder(1,1,j),auxmat(1,1))
6689         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
6690         call transpose2(EUg(1,1,j),auxmat(1,1))
6691         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6692         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6693         do iii=1,2
6694           do kkk=1,5
6695             do lll=1,3
6696               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6697      &          EAEAderx(1,1,lll,kkk,iii,2))
6698             enddo
6699           enddo
6700         enddo
6701 C AEAb1 and AEAb2
6702 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6703 C They are needed only when the fifth- or the sixth-order cumulants are
6704 C indluded.
6705         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
6706      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
6707         call transpose2(AEA(1,1,1),auxmat(1,1))
6708         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
6709         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6710         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6711         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6712         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
6713         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6714         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
6715         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
6716         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6717         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6718         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6719         call transpose2(AEA(1,1,2),auxmat(1,1))
6720         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
6721         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
6722         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
6723         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6724         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
6725         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
6726         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
6727         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
6728         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
6729         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
6730         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
6731 C Calculate the Cartesian derivatives of the vectors.
6732         do iii=1,2
6733           do kkk=1,5
6734             do lll=1,3
6735               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6736               call matvec2(auxmat(1,1),b1(1,iti),
6737      &          AEAb1derx(1,lll,kkk,iii,1,1))
6738               call matvec2(auxmat(1,1),Ub2(1,i),
6739      &          AEAb2derx(1,lll,kkk,iii,1,1))
6740               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
6741      &          AEAb1derx(1,lll,kkk,iii,2,1))
6742               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
6743      &          AEAb2derx(1,lll,kkk,iii,2,1))
6744               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
6745               call matvec2(auxmat(1,1),b1(1,itl),
6746      &          AEAb1derx(1,lll,kkk,iii,1,2))
6747               call matvec2(auxmat(1,1),Ub2(1,l),
6748      &          AEAb2derx(1,lll,kkk,iii,1,2))
6749               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
6750      &          AEAb1derx(1,lll,kkk,iii,2,2))
6751               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
6752      &          AEAb2derx(1,lll,kkk,iii,2,2))
6753             enddo
6754           enddo
6755         enddo
6756         ENDIF
6757 C End vectors
6758       endif
6759       return
6760       end
6761 C---------------------------------------------------------------------------
6762       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
6763      &  KK,KKderg,AKA,AKAderg,AKAderx)
6764       implicit none
6765       integer nderg
6766       logical transp
6767       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
6768      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
6769      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
6770       integer iii,kkk,lll
6771       integer jjj,mmm
6772       logical lprn
6773       common /kutas/ lprn
6774       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
6775       do iii=1,nderg
6776         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
6777      &    AKAderg(1,1,iii))
6778       enddo
6779 cd      if (lprn) write (2,*) 'In kernel'
6780       do kkk=1,5
6781 cd        if (lprn) write (2,*) 'kkk=',kkk
6782         do lll=1,3
6783           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
6784      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
6785 cd          if (lprn) then
6786 cd            write (2,*) 'lll=',lll
6787 cd            write (2,*) 'iii=1'
6788 cd            do jjj=1,2
6789 cd              write (2,'(3(2f10.5),5x)')
6790 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
6791 cd            enddo
6792 cd          endif
6793           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
6794      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
6795 cd          if (lprn) then
6796 cd            write (2,*) 'lll=',lll
6797 cd            write (2,*) 'iii=2'
6798 cd            do jjj=1,2
6799 cd              write (2,'(3(2f10.5),5x)')
6800 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
6801 cd            enddo
6802 cd          endif
6803         enddo
6804       enddo
6805       return
6806       end
6807 C---------------------------------------------------------------------------
6808       double precision function eello4(i,j,k,l,jj,kk)
6809       implicit real*8 (a-h,o-z)
6810       include 'DIMENSIONS'
6811       include 'DIMENSIONS.ZSCOPT'
6812       include 'COMMON.IOUNITS'
6813       include 'COMMON.CHAIN'
6814       include 'COMMON.DERIV'
6815       include 'COMMON.INTERACT'
6816       include 'COMMON.CONTACTS'
6817       include 'COMMON.TORSION'
6818       include 'COMMON.VAR'
6819       include 'COMMON.GEO'
6820       double precision pizda(2,2),ggg1(3),ggg2(3)
6821 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
6822 cd        eello4=0.0d0
6823 cd        return
6824 cd      endif
6825 cd      print *,'eello4:',i,j,k,l,jj,kk
6826 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
6827 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
6828 cold      eij=facont_hb(jj,i)
6829 cold      ekl=facont_hb(kk,k)
6830 cold      ekont=eij*ekl
6831       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
6832       if (calc_grad) then
6833 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
6834       gcorr_loc(k-1)=gcorr_loc(k-1)
6835      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
6836       if (l.eq.j+1) then
6837         gcorr_loc(l-1)=gcorr_loc(l-1)
6838      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6839       else
6840         gcorr_loc(j-1)=gcorr_loc(j-1)
6841      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
6842       endif
6843       do iii=1,2
6844         do kkk=1,5
6845           do lll=1,3
6846             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
6847      &                        -EAEAderx(2,2,lll,kkk,iii,1)
6848 cd            derx(lll,kkk,iii)=0.0d0
6849           enddo
6850         enddo
6851       enddo
6852 cd      gcorr_loc(l-1)=0.0d0
6853 cd      gcorr_loc(j-1)=0.0d0
6854 cd      gcorr_loc(k-1)=0.0d0
6855 cd      eel4=1.0d0
6856 cd      write (iout,*)'Contacts have occurred for peptide groups',
6857 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
6858 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
6859       if (j.lt.nres-1) then
6860         j1=j+1
6861         j2=j-1
6862       else
6863         j1=j-1
6864         j2=j-2
6865       endif
6866       if (l.lt.nres-1) then
6867         l1=l+1
6868         l2=l-1
6869       else
6870         l1=l-1
6871         l2=l-2
6872       endif
6873       do ll=1,3
6874 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
6875         ggg1(ll)=eel4*g_contij(ll,1)
6876         ggg2(ll)=eel4*g_contij(ll,2)
6877         ghalf=0.5d0*ggg1(ll)
6878 cd        ghalf=0.0d0
6879         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
6880         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
6881         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
6882         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
6883 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
6884         ghalf=0.5d0*ggg2(ll)
6885 cd        ghalf=0.0d0
6886         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
6887         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
6888         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
6889         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
6890       enddo
6891 cd      goto 1112
6892       do m=i+1,j-1
6893         do ll=1,3
6894 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
6895           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
6896         enddo
6897       enddo
6898       do m=k+1,l-1
6899         do ll=1,3
6900 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
6901           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
6902         enddo
6903       enddo
6904 1112  continue
6905       do m=i+2,j2
6906         do ll=1,3
6907           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
6908         enddo
6909       enddo
6910       do m=k+2,l2
6911         do ll=1,3
6912           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
6913         enddo
6914       enddo
6915 cd      do iii=1,nres-3
6916 cd        write (2,*) iii,gcorr_loc(iii)
6917 cd      enddo
6918       endif
6919       eello4=ekont*eel4
6920 cd      write (2,*) 'ekont',ekont
6921 cd      write (iout,*) 'eello4',ekont*eel4
6922       return
6923       end
6924 C---------------------------------------------------------------------------
6925       double precision function eello5(i,j,k,l,jj,kk)
6926       implicit real*8 (a-h,o-z)
6927       include 'DIMENSIONS'
6928       include 'DIMENSIONS.ZSCOPT'
6929       include 'COMMON.IOUNITS'
6930       include 'COMMON.CHAIN'
6931       include 'COMMON.DERIV'
6932       include 'COMMON.INTERACT'
6933       include 'COMMON.CONTACTS'
6934       include 'COMMON.TORSION'
6935       include 'COMMON.VAR'
6936       include 'COMMON.GEO'
6937       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
6938       double precision ggg1(3),ggg2(3)
6939 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6940 C                                                                              C
6941 C                            Parallel chains                                   C
6942 C                                                                              C
6943 C          o             o                   o             o                   C
6944 C         /l\           / \             \   / \           / \   /              C
6945 C        /   \         /   \             \ /   \         /   \ /               C
6946 C       j| o |l1       | o |              o| o |         | o |o                C
6947 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6948 C      \i/   \         /   \ /             /   \         /   \                 C
6949 C       o    k1             o                                                  C
6950 C         (I)          (II)                (III)          (IV)                 C
6951 C                                                                              C
6952 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6953 C                                                                              C
6954 C                            Antiparallel chains                               C
6955 C                                                                              C
6956 C          o             o                   o             o                   C
6957 C         /j\           / \             \   / \           / \   /              C
6958 C        /   \         /   \             \ /   \         /   \ /               C
6959 C      j1| o |l        | o |              o| o |         | o |o                C
6960 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
6961 C      \i/   \         /   \ /             /   \         /   \                 C
6962 C       o     k1            o                                                  C
6963 C         (I)          (II)                (III)          (IV)                 C
6964 C                                                                              C
6965 C      eello5_1        eello5_2            eello5_3       eello5_4             C
6966 C                                                                              C
6967 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
6968 C                                                                              C
6969 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
6970 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
6971 cd        eello5=0.0d0
6972 cd        return
6973 cd      endif
6974 cd      write (iout,*)
6975 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
6976 cd     &   ' and',k,l
6977       itk=itortyp(itype(k))
6978       itl=itortyp(itype(l))
6979       itj=itortyp(itype(j))
6980       eello5_1=0.0d0
6981       eello5_2=0.0d0
6982       eello5_3=0.0d0
6983       eello5_4=0.0d0
6984 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
6985 cd     &   eel5_3_num,eel5_4_num)
6986       do iii=1,2
6987         do kkk=1,5
6988           do lll=1,3
6989             derx(lll,kkk,iii)=0.0d0
6990           enddo
6991         enddo
6992       enddo
6993 cd      eij=facont_hb(jj,i)
6994 cd      ekl=facont_hb(kk,k)
6995 cd      ekont=eij*ekl
6996 cd      write (iout,*)'Contacts have occurred for peptide groups',
6997 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
6998 cd      goto 1111
6999 C Contribution from the graph I.
7000 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7001 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7002       call transpose2(EUg(1,1,k),auxmat(1,1))
7003       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7004       vv(1)=pizda(1,1)-pizda(2,2)
7005       vv(2)=pizda(1,2)+pizda(2,1)
7006       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7007      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7008       if (calc_grad) then
7009 C Explicit gradient in virtual-dihedral angles.
7010       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7011      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7012      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7013       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7014       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7015       vv(1)=pizda(1,1)-pizda(2,2)
7016       vv(2)=pizda(1,2)+pizda(2,1)
7017       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7018      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7019      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7020       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7021       vv(1)=pizda(1,1)-pizda(2,2)
7022       vv(2)=pizda(1,2)+pizda(2,1)
7023       if (l.eq.j+1) then
7024         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7025      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7026      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7027       else
7028         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7029      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7030      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7031       endif
7032 C Cartesian gradient
7033       do iii=1,2
7034         do kkk=1,5
7035           do lll=1,3
7036             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7037      &        pizda(1,1))
7038             vv(1)=pizda(1,1)-pizda(2,2)
7039             vv(2)=pizda(1,2)+pizda(2,1)
7040             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7041      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7042      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7043           enddo
7044         enddo
7045       enddo
7046 c      goto 1112
7047       endif
7048 c1111  continue
7049 C Contribution from graph II
7050       call transpose2(EE(1,1,itk),auxmat(1,1))
7051       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7052       vv(1)=pizda(1,1)+pizda(2,2)
7053       vv(2)=pizda(2,1)-pizda(1,2)
7054       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7055      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7056       if (calc_grad) then
7057 C Explicit gradient in virtual-dihedral angles.
7058       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7059      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7060       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7061       vv(1)=pizda(1,1)+pizda(2,2)
7062       vv(2)=pizda(2,1)-pizda(1,2)
7063       if (l.eq.j+1) then
7064         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7065      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7066      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7067       else
7068         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7069      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7070      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7071       endif
7072 C Cartesian gradient
7073       do iii=1,2
7074         do kkk=1,5
7075           do lll=1,3
7076             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7077      &        pizda(1,1))
7078             vv(1)=pizda(1,1)+pizda(2,2)
7079             vv(2)=pizda(2,1)-pizda(1,2)
7080             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7081      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7082      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7083           enddo
7084         enddo
7085       enddo
7086 cd      goto 1112
7087       endif
7088 cd1111  continue
7089       if (l.eq.j+1) then
7090 cd        goto 1110
7091 C Parallel orientation
7092 C Contribution from graph III
7093         call transpose2(EUg(1,1,l),auxmat(1,1))
7094         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7095         vv(1)=pizda(1,1)-pizda(2,2)
7096         vv(2)=pizda(1,2)+pizda(2,1)
7097         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7098      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7099         if (calc_grad) then
7100 C Explicit gradient in virtual-dihedral angles.
7101         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7102      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7103      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7104         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7105         vv(1)=pizda(1,1)-pizda(2,2)
7106         vv(2)=pizda(1,2)+pizda(2,1)
7107         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7108      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7109      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7110         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7111         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7112         vv(1)=pizda(1,1)-pizda(2,2)
7113         vv(2)=pizda(1,2)+pizda(2,1)
7114         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7115      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7116      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7117 C Cartesian gradient
7118         do iii=1,2
7119           do kkk=1,5
7120             do lll=1,3
7121               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7122      &          pizda(1,1))
7123               vv(1)=pizda(1,1)-pizda(2,2)
7124               vv(2)=pizda(1,2)+pizda(2,1)
7125               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7126      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7127      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7128             enddo
7129           enddo
7130         enddo
7131 cd        goto 1112
7132         endif
7133 C Contribution from graph IV
7134 cd1110    continue
7135         call transpose2(EE(1,1,itl),auxmat(1,1))
7136         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7137         vv(1)=pizda(1,1)+pizda(2,2)
7138         vv(2)=pizda(2,1)-pizda(1,2)
7139         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7140      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7141         if (calc_grad) then
7142 C Explicit gradient in virtual-dihedral angles.
7143         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7144      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7145         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7146         vv(1)=pizda(1,1)+pizda(2,2)
7147         vv(2)=pizda(2,1)-pizda(1,2)
7148         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7149      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7150      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7151 C Cartesian gradient
7152         do iii=1,2
7153           do kkk=1,5
7154             do lll=1,3
7155               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7156      &          pizda(1,1))
7157               vv(1)=pizda(1,1)+pizda(2,2)
7158               vv(2)=pizda(2,1)-pizda(1,2)
7159               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7160      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7161      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7162             enddo
7163           enddo
7164         enddo
7165         endif
7166       else
7167 C Antiparallel orientation
7168 C Contribution from graph III
7169 c        goto 1110
7170         call transpose2(EUg(1,1,j),auxmat(1,1))
7171         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7172         vv(1)=pizda(1,1)-pizda(2,2)
7173         vv(2)=pizda(1,2)+pizda(2,1)
7174         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7175      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7176         if (calc_grad) then
7177 C Explicit gradient in virtual-dihedral angles.
7178         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7179      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7180      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7181         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7182         vv(1)=pizda(1,1)-pizda(2,2)
7183         vv(2)=pizda(1,2)+pizda(2,1)
7184         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7185      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7186      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7187         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7188         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7189         vv(1)=pizda(1,1)-pizda(2,2)
7190         vv(2)=pizda(1,2)+pizda(2,1)
7191         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7192      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7193      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7194 C Cartesian gradient
7195         do iii=1,2
7196           do kkk=1,5
7197             do lll=1,3
7198               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7199      &          pizda(1,1))
7200               vv(1)=pizda(1,1)-pizda(2,2)
7201               vv(2)=pizda(1,2)+pizda(2,1)
7202               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7203      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7204      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7205             enddo
7206           enddo
7207         enddo
7208 cd        goto 1112
7209         endif
7210 C Contribution from graph IV
7211 1110    continue
7212         call transpose2(EE(1,1,itj),auxmat(1,1))
7213         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7214         vv(1)=pizda(1,1)+pizda(2,2)
7215         vv(2)=pizda(2,1)-pizda(1,2)
7216         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7217      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7218         if (calc_grad) then
7219 C Explicit gradient in virtual-dihedral angles.
7220         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7221      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7222         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7223         vv(1)=pizda(1,1)+pizda(2,2)
7224         vv(2)=pizda(2,1)-pizda(1,2)
7225         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7226      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7227      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7228 C Cartesian gradient
7229         do iii=1,2
7230           do kkk=1,5
7231             do lll=1,3
7232               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7233      &          pizda(1,1))
7234               vv(1)=pizda(1,1)+pizda(2,2)
7235               vv(2)=pizda(2,1)-pizda(1,2)
7236               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7237      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7238      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7239             enddo
7240           enddo
7241         enddo
7242       endif
7243       endif
7244 1112  continue
7245       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7246 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7247 cd        write (2,*) 'ijkl',i,j,k,l
7248 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7249 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7250 cd      endif
7251 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7252 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7253 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7254 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7255       if (calc_grad) then
7256       if (j.lt.nres-1) then
7257         j1=j+1
7258         j2=j-1
7259       else
7260         j1=j-1
7261         j2=j-2
7262       endif
7263       if (l.lt.nres-1) then
7264         l1=l+1
7265         l2=l-1
7266       else
7267         l1=l-1
7268         l2=l-2
7269       endif
7270 cd      eij=1.0d0
7271 cd      ekl=1.0d0
7272 cd      ekont=1.0d0
7273 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7274       do ll=1,3
7275         ggg1(ll)=eel5*g_contij(ll,1)
7276         ggg2(ll)=eel5*g_contij(ll,2)
7277 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7278         ghalf=0.5d0*ggg1(ll)
7279 cd        ghalf=0.0d0
7280         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7281         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7282         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7283         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7284 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7285         ghalf=0.5d0*ggg2(ll)
7286 cd        ghalf=0.0d0
7287         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7288         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7289         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7290         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7291       enddo
7292 cd      goto 1112
7293       do m=i+1,j-1
7294         do ll=1,3
7295 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7296           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7297         enddo
7298       enddo
7299       do m=k+1,l-1
7300         do ll=1,3
7301 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7302           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7303         enddo
7304       enddo
7305 c1112  continue
7306       do m=i+2,j2
7307         do ll=1,3
7308           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7309         enddo
7310       enddo
7311       do m=k+2,l2
7312         do ll=1,3
7313           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7314         enddo
7315       enddo
7316 cd      do iii=1,nres-3
7317 cd        write (2,*) iii,g_corr5_loc(iii)
7318 cd      enddo
7319       endif
7320       eello5=ekont*eel5
7321 cd      write (2,*) 'ekont',ekont
7322 cd      write (iout,*) 'eello5',ekont*eel5
7323       return
7324       end
7325 c--------------------------------------------------------------------------
7326       double precision function eello6(i,j,k,l,jj,kk)
7327       implicit real*8 (a-h,o-z)
7328       include 'DIMENSIONS'
7329       include 'DIMENSIONS.ZSCOPT'
7330       include 'COMMON.IOUNITS'
7331       include 'COMMON.CHAIN'
7332       include 'COMMON.DERIV'
7333       include 'COMMON.INTERACT'
7334       include 'COMMON.CONTACTS'
7335       include 'COMMON.TORSION'
7336       include 'COMMON.VAR'
7337       include 'COMMON.GEO'
7338       include 'COMMON.FFIELD'
7339       double precision ggg1(3),ggg2(3)
7340 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7341 cd        eello6=0.0d0
7342 cd        return
7343 cd      endif
7344 cd      write (iout,*)
7345 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7346 cd     &   ' and',k,l
7347       eello6_1=0.0d0
7348       eello6_2=0.0d0
7349       eello6_3=0.0d0
7350       eello6_4=0.0d0
7351       eello6_5=0.0d0
7352       eello6_6=0.0d0
7353 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7354 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7355       do iii=1,2
7356         do kkk=1,5
7357           do lll=1,3
7358             derx(lll,kkk,iii)=0.0d0
7359           enddo
7360         enddo
7361       enddo
7362 cd      eij=facont_hb(jj,i)
7363 cd      ekl=facont_hb(kk,k)
7364 cd      ekont=eij*ekl
7365 cd      eij=1.0d0
7366 cd      ekl=1.0d0
7367 cd      ekont=1.0d0
7368       if (l.eq.j+1) then
7369         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7370         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7371         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7372         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7373         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7374         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7375       else
7376         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7377         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7378         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7379         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7380         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7381           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7382         else
7383           eello6_5=0.0d0
7384         endif
7385         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7386       endif
7387 C If turn contributions are considered, they will be handled separately.
7388       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7389 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7390 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7391 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7392 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7393 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7394 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7395 cd      goto 1112
7396       if (calc_grad) then
7397       if (j.lt.nres-1) then
7398         j1=j+1
7399         j2=j-1
7400       else
7401         j1=j-1
7402         j2=j-2
7403       endif
7404       if (l.lt.nres-1) then
7405         l1=l+1
7406         l2=l-1
7407       else
7408         l1=l-1
7409         l2=l-2
7410       endif
7411       do ll=1,3
7412         ggg1(ll)=eel6*g_contij(ll,1)
7413         ggg2(ll)=eel6*g_contij(ll,2)
7414 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7415         ghalf=0.5d0*ggg1(ll)
7416 cd        ghalf=0.0d0
7417         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7418         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7419         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7420         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7421         ghalf=0.5d0*ggg2(ll)
7422 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7423 cd        ghalf=0.0d0
7424         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7425         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7426         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7427         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7428       enddo
7429 cd      goto 1112
7430       do m=i+1,j-1
7431         do ll=1,3
7432 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7433           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7434         enddo
7435       enddo
7436       do m=k+1,l-1
7437         do ll=1,3
7438 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7439           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7440         enddo
7441       enddo
7442 1112  continue
7443       do m=i+2,j2
7444         do ll=1,3
7445           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7446         enddo
7447       enddo
7448       do m=k+2,l2
7449         do ll=1,3
7450           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7451         enddo
7452       enddo
7453 cd      do iii=1,nres-3
7454 cd        write (2,*) iii,g_corr6_loc(iii)
7455 cd      enddo
7456       endif
7457       eello6=ekont*eel6
7458 cd      write (2,*) 'ekont',ekont
7459 cd      write (iout,*) 'eello6',ekont*eel6
7460       return
7461       end
7462 c--------------------------------------------------------------------------
7463       double precision function eello6_graph1(i,j,k,l,imat,swap)
7464       implicit real*8 (a-h,o-z)
7465       include 'DIMENSIONS'
7466       include 'DIMENSIONS.ZSCOPT'
7467       include 'COMMON.IOUNITS'
7468       include 'COMMON.CHAIN'
7469       include 'COMMON.DERIV'
7470       include 'COMMON.INTERACT'
7471       include 'COMMON.CONTACTS'
7472       include 'COMMON.TORSION'
7473       include 'COMMON.VAR'
7474       include 'COMMON.GEO'
7475       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7476       logical swap
7477       logical lprn
7478       common /kutas/ lprn
7479 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7480 C                                                                              C
7481 C      Parallel       Antiparallel                                             C
7482 C                                                                              C
7483 C          o             o                                                     C
7484 C         /l\           /j\                                                    C
7485 C        /   \         /   \                                                   C
7486 C       /| o |         | o |\                                                  C
7487 C     \ j|/k\|  /   \  |/k\|l /                                                C
7488 C      \ /   \ /     \ /   \ /                                                 C
7489 C       o     o       o     o                                                  C
7490 C       i             i                                                        C
7491 C                                                                              C
7492 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7493       itk=itortyp(itype(k))
7494       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7495       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7496       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7497       call transpose2(EUgC(1,1,k),auxmat(1,1))
7498       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7499       vv1(1)=pizda1(1,1)-pizda1(2,2)
7500       vv1(2)=pizda1(1,2)+pizda1(2,1)
7501       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7502       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
7503       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
7504       s5=scalar2(vv(1),Dtobr2(1,i))
7505 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7506       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7507       if (.not. calc_grad) return
7508       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7509      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7510      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7511      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7512      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7513      & +scalar2(vv(1),Dtobr2der(1,i)))
7514       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7515       vv1(1)=pizda1(1,1)-pizda1(2,2)
7516       vv1(2)=pizda1(1,2)+pizda1(2,1)
7517       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
7518       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
7519       if (l.eq.j+1) then
7520         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7521      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7522      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7523      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7524      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7525       else
7526         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7527      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7528      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7529      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7530      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7531       endif
7532       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7533       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7534       vv1(1)=pizda1(1,1)-pizda1(2,2)
7535       vv1(2)=pizda1(1,2)+pizda1(2,1)
7536       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7537      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7538      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7539      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7540       do iii=1,2
7541         if (swap) then
7542           ind=3-iii
7543         else
7544           ind=iii
7545         endif
7546         do kkk=1,5
7547           do lll=1,3
7548             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7549             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7550             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7551             call transpose2(EUgC(1,1,k),auxmat(1,1))
7552             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7553      &        pizda1(1,1))
7554             vv1(1)=pizda1(1,1)-pizda1(2,2)
7555             vv1(2)=pizda1(1,2)+pizda1(2,1)
7556             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7557             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
7558      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
7559             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
7560      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
7561             s5=scalar2(vv(1),Dtobr2(1,i))
7562             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7563           enddo
7564         enddo
7565       enddo
7566       return
7567       end
7568 c----------------------------------------------------------------------------
7569       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7570       implicit real*8 (a-h,o-z)
7571       include 'DIMENSIONS'
7572       include 'DIMENSIONS.ZSCOPT'
7573       include 'COMMON.IOUNITS'
7574       include 'COMMON.CHAIN'
7575       include 'COMMON.DERIV'
7576       include 'COMMON.INTERACT'
7577       include 'COMMON.CONTACTS'
7578       include 'COMMON.TORSION'
7579       include 'COMMON.VAR'
7580       include 'COMMON.GEO'
7581       logical swap
7582       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7583      & auxvec1(2),auxvec2(2),auxmat1(2,2)
7584       logical lprn
7585       common /kutas/ lprn
7586 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7587 C                                                                              C
7588 C      Parallel       Antiparallel                                             C
7589 C                                                                              C
7590 C          o             o                                                     C
7591 C     \   /l\           /j\   /                                                C
7592 C      \ /   \         /   \ /                                                 C
7593 C       o| o |         | o |o                                                  C
7594 C     \ j|/k\|      \  |/k\|l                                                  C
7595 C      \ /   \       \ /   \                                                   C
7596 C       o             o                                                        C
7597 C       i             i                                                        C
7598 C                                                                              C
7599 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7600 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
7601 C AL 7/4/01 s1 would occur in the sixth-order moment,
7602 C           but not in a cluster cumulant
7603 #ifdef MOMENT
7604       s1=dip(1,jj,i)*dip(1,kk,k)
7605 #endif
7606       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
7607       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7608       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
7609       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
7610       call transpose2(EUg(1,1,k),auxmat(1,1))
7611       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
7612       vv(1)=pizda(1,1)-pizda(2,2)
7613       vv(2)=pizda(1,2)+pizda(2,1)
7614       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7615 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7616 #ifdef MOMENT
7617       eello6_graph2=-(s1+s2+s3+s4)
7618 #else
7619       eello6_graph2=-(s2+s3+s4)
7620 #endif
7621 c      eello6_graph2=-s3
7622       if (.not. calc_grad) return
7623 C Derivatives in gamma(i-1)
7624       if (i.gt.1) then
7625 #ifdef MOMENT
7626         s1=dipderg(1,jj,i)*dip(1,kk,k)
7627 #endif
7628         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7629         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
7630         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7631         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7632 #ifdef MOMENT
7633         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7634 #else
7635         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7636 #endif
7637 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
7638       endif
7639 C Derivatives in gamma(k-1)
7640 #ifdef MOMENT
7641       s1=dip(1,jj,i)*dipderg(1,kk,k)
7642 #endif
7643       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
7644       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7645       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
7646       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7647       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7648       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
7649       vv(1)=pizda(1,1)-pizda(2,2)
7650       vv(2)=pizda(1,2)+pizda(2,1)
7651       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7652 #ifdef MOMENT
7653       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
7654 #else
7655       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
7656 #endif
7657 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
7658 C Derivatives in gamma(j-1) or gamma(l-1)
7659       if (j.gt.1) then
7660 #ifdef MOMENT
7661         s1=dipderg(3,jj,i)*dip(1,kk,k)
7662 #endif
7663         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
7664         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7665         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
7666         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
7667         vv(1)=pizda(1,1)-pizda(2,2)
7668         vv(2)=pizda(1,2)+pizda(2,1)
7669         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7670 #ifdef MOMENT
7671         if (swap) then
7672           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7673         else
7674           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7675         endif
7676 #endif
7677         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
7678 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
7679       endif
7680 C Derivatives in gamma(l-1) or gamma(j-1)
7681       if (l.gt.1) then
7682 #ifdef MOMENT
7683         s1=dip(1,jj,i)*dipderg(3,kk,k)
7684 #endif
7685         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
7686         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
7687         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
7688         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
7689         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
7690         vv(1)=pizda(1,1)-pizda(2,2)
7691         vv(2)=pizda(1,2)+pizda(2,1)
7692         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7693 #ifdef MOMENT
7694         if (swap) then
7695           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
7696         else
7697           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
7698         endif
7699 #endif
7700         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
7701 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
7702       endif
7703 C Cartesian derivatives.
7704       if (lprn) then
7705         write (2,*) 'In eello6_graph2'
7706         do iii=1,2
7707           write (2,*) 'iii=',iii
7708           do kkk=1,5
7709             write (2,*) 'kkk=',kkk
7710             do jjj=1,2
7711               write (2,'(3(2f10.5),5x)')
7712      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7713             enddo
7714           enddo
7715         enddo
7716       endif
7717       do iii=1,2
7718         do kkk=1,5
7719           do lll=1,3
7720 #ifdef MOMENT
7721             if (iii.eq.1) then
7722               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
7723             else
7724               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
7725             endif
7726 #endif
7727             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
7728      &        auxvec(1))
7729             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
7730             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
7731      &        auxvec(1))
7732             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
7733             call transpose2(EUg(1,1,k),auxmat(1,1))
7734             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
7735      &        pizda(1,1))
7736             vv(1)=pizda(1,1)-pizda(2,2)
7737             vv(2)=pizda(1,2)+pizda(2,1)
7738             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
7739 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
7740 #ifdef MOMENT
7741             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7742 #else
7743             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7744 #endif
7745             if (swap) then
7746               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7747             else
7748               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7749             endif
7750           enddo
7751         enddo
7752       enddo
7753       return
7754       end
7755 c----------------------------------------------------------------------------
7756       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
7757       implicit real*8 (a-h,o-z)
7758       include 'DIMENSIONS'
7759       include 'DIMENSIONS.ZSCOPT'
7760       include 'COMMON.IOUNITS'
7761       include 'COMMON.CHAIN'
7762       include 'COMMON.DERIV'
7763       include 'COMMON.INTERACT'
7764       include 'COMMON.CONTACTS'
7765       include 'COMMON.TORSION'
7766       include 'COMMON.VAR'
7767       include 'COMMON.GEO'
7768       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
7769       logical swap
7770 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7771 C                                                                              C
7772 C      Parallel       Antiparallel                                             C
7773 C                                                                              C
7774 C          o             o                                                     C
7775 C         /l\   /   \   /j\                                                    C
7776 C        /   \ /     \ /   \                                                   C
7777 C       /| o |o       o| o |\                                                  C
7778 C       j|/k\|  /      |/k\|l /                                                C
7779 C        /   \ /       /   \ /                                                 C
7780 C       /     o       /     o                                                  C
7781 C       i             i                                                        C
7782 C                                                                              C
7783 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7784 C
7785 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7786 C           energy moment and not to the cluster cumulant.
7787       iti=itortyp(itype(i))
7788       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7789         itj1=itortyp(itype(j+1))
7790       else
7791         itj1=ntortyp+1
7792       endif
7793       itk=itortyp(itype(k))
7794       itk1=itortyp(itype(k+1))
7795       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7796         itl1=itortyp(itype(l+1))
7797       else
7798         itl1=ntortyp+1
7799       endif
7800 #ifdef MOMENT
7801       s1=dip(4,jj,i)*dip(4,kk,k)
7802 #endif
7803       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
7804       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7805       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
7806       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7807       call transpose2(EE(1,1,itk),auxmat(1,1))
7808       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
7809       vv(1)=pizda(1,1)+pizda(2,2)
7810       vv(2)=pizda(2,1)-pizda(1,2)
7811       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7812 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7813 #ifdef MOMENT
7814       eello6_graph3=-(s1+s2+s3+s4)
7815 #else
7816       eello6_graph3=-(s2+s3+s4)
7817 #endif
7818 c      eello6_graph3=-s4
7819       if (.not. calc_grad) return
7820 C Derivatives in gamma(k-1)
7821       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
7822       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7823       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
7824       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
7825 C Derivatives in gamma(l-1)
7826       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
7827       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7828       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
7829       vv(1)=pizda(1,1)+pizda(2,2)
7830       vv(2)=pizda(2,1)-pizda(1,2)
7831       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7832       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
7833 C Cartesian derivatives.
7834       do iii=1,2
7835         do kkk=1,5
7836           do lll=1,3
7837 #ifdef MOMENT
7838             if (iii.eq.1) then
7839               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
7840             else
7841               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
7842             endif
7843 #endif
7844             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7845      &        auxvec(1))
7846             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
7847             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7848      &        auxvec(1))
7849             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
7850             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
7851      &        pizda(1,1))
7852             vv(1)=pizda(1,1)+pizda(2,2)
7853             vv(2)=pizda(2,1)-pizda(1,2)
7854             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
7855 #ifdef MOMENT
7856             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
7857 #else
7858             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
7859 #endif
7860             if (swap) then
7861               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
7862             else
7863               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
7864             endif
7865 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
7866           enddo
7867         enddo
7868       enddo
7869       return
7870       end
7871 c----------------------------------------------------------------------------
7872       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
7873       implicit real*8 (a-h,o-z)
7874       include 'DIMENSIONS'
7875       include 'DIMENSIONS.ZSCOPT'
7876       include 'COMMON.IOUNITS'
7877       include 'COMMON.CHAIN'
7878       include 'COMMON.DERIV'
7879       include 'COMMON.INTERACT'
7880       include 'COMMON.CONTACTS'
7881       include 'COMMON.TORSION'
7882       include 'COMMON.VAR'
7883       include 'COMMON.GEO'
7884       include 'COMMON.FFIELD'
7885       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
7886      & auxvec1(2),auxmat1(2,2)
7887       logical swap
7888 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7889 C                                                                              C
7890 C      Parallel       Antiparallel                                             C
7891 C                                                                              C
7892 C          o             o                                                     C
7893 C         /l\   /   \   /j\                                                    C
7894 C        /   \ /     \ /   \                                                   C
7895 C       /| o |o       o| o |\                                                  C
7896 C     \ j|/k\|      \  |/k\|l                                                  C
7897 C      \ /   \       \ /   \                                                   C
7898 C       o     \       o     \                                                  C
7899 C       i             i                                                        C
7900 C                                                                              C
7901 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7902 C
7903 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
7904 C           energy moment and not to the cluster cumulant.
7905 cd      write (2,*) 'eello_graph4: wturn6',wturn6
7906       iti=itortyp(itype(i))
7907       itj=itortyp(itype(j))
7908       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7909         itj1=itortyp(itype(j+1))
7910       else
7911         itj1=ntortyp+1
7912       endif
7913       itk=itortyp(itype(k))
7914       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
7915         itk1=itortyp(itype(k+1))
7916       else
7917         itk1=ntortyp+1
7918       endif
7919       itl=itortyp(itype(l))
7920       if (l.lt.nres-1) then
7921         itl1=itortyp(itype(l+1))
7922       else
7923         itl1=ntortyp+1
7924       endif
7925 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
7926 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
7927 cd     & ' itl',itl,' itl1',itl1
7928 #ifdef MOMENT
7929       if (imat.eq.1) then
7930         s1=dip(3,jj,i)*dip(3,kk,k)
7931       else
7932         s1=dip(2,jj,j)*dip(2,kk,l)
7933       endif
7934 #endif
7935       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
7936       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
7937       if (j.eq.l+1) then
7938         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
7939         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7940       else
7941         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
7942         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7943       endif
7944       call transpose2(EUg(1,1,k),auxmat(1,1))
7945       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
7946       vv(1)=pizda(1,1)-pizda(2,2)
7947       vv(2)=pizda(2,1)+pizda(1,2)
7948       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
7949 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
7950 #ifdef MOMENT
7951       eello6_graph4=-(s1+s2+s3+s4)
7952 #else
7953       eello6_graph4=-(s2+s3+s4)
7954 #endif
7955       if (.not. calc_grad) return
7956 C Derivatives in gamma(i-1)
7957       if (i.gt.1) then
7958 #ifdef MOMENT
7959         if (imat.eq.1) then
7960           s1=dipderg(2,jj,i)*dip(3,kk,k)
7961         else
7962           s1=dipderg(4,jj,j)*dip(2,kk,l)
7963         endif
7964 #endif
7965         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
7966         if (j.eq.l+1) then
7967           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
7968           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
7969         else
7970           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
7971           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
7972         endif
7973         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
7974         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
7975 cd          write (2,*) 'turn6 derivatives'
7976 #ifdef MOMENT
7977           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
7978 #else
7979           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
7980 #endif
7981         else
7982 #ifdef MOMENT
7983           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
7984 #else
7985           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
7986 #endif
7987         endif
7988       endif
7989 C Derivatives in gamma(k-1)
7990 #ifdef MOMENT
7991       if (imat.eq.1) then
7992         s1=dip(3,jj,i)*dipderg(2,kk,k)
7993       else
7994         s1=dip(2,jj,j)*dipderg(4,kk,l)
7995       endif
7996 #endif
7997       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
7998       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
7999       if (j.eq.l+1) then
8000         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8001         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8002       else
8003         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8004         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8005       endif
8006       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8007       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8008       vv(1)=pizda(1,1)-pizda(2,2)
8009       vv(2)=pizda(2,1)+pizda(1,2)
8010       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8011       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8012 #ifdef MOMENT
8013         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8014 #else
8015         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8016 #endif
8017       else
8018 #ifdef MOMENT
8019         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8020 #else
8021         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8022 #endif
8023       endif
8024 C Derivatives in gamma(j-1) or gamma(l-1)
8025       if (l.eq.j+1 .and. l.gt.1) then
8026         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8027         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8028         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8029         vv(1)=pizda(1,1)-pizda(2,2)
8030         vv(2)=pizda(2,1)+pizda(1,2)
8031         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8032         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8033       else if (j.gt.1) then
8034         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8035         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8036         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8037         vv(1)=pizda(1,1)-pizda(2,2)
8038         vv(2)=pizda(2,1)+pizda(1,2)
8039         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8040         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8041           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8042         else
8043           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8044         endif
8045       endif
8046 C Cartesian derivatives.
8047       do iii=1,2
8048         do kkk=1,5
8049           do lll=1,3
8050 #ifdef MOMENT
8051             if (iii.eq.1) then
8052               if (imat.eq.1) then
8053                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8054               else
8055                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8056               endif
8057             else
8058               if (imat.eq.1) then
8059                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8060               else
8061                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8062               endif
8063             endif
8064 #endif
8065             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8066      &        auxvec(1))
8067             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8068             if (j.eq.l+1) then
8069               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8070      &          b1(1,itj1),auxvec(1))
8071               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8072             else
8073               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8074      &          b1(1,itl1),auxvec(1))
8075               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8076             endif
8077             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8078      &        pizda(1,1))
8079             vv(1)=pizda(1,1)-pizda(2,2)
8080             vv(2)=pizda(2,1)+pizda(1,2)
8081             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8082             if (swap) then
8083               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8084 #ifdef MOMENT
8085                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8086      &             -(s1+s2+s4)
8087 #else
8088                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8089      &             -(s2+s4)
8090 #endif
8091                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8092               else
8093 #ifdef MOMENT
8094                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8095 #else
8096                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8097 #endif
8098                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8099               endif
8100             else
8101 #ifdef MOMENT
8102               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8103 #else
8104               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8105 #endif
8106               if (l.eq.j+1) then
8107                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8108               else
8109                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8110               endif
8111             endif
8112           enddo
8113         enddo
8114       enddo
8115       return
8116       end
8117 c----------------------------------------------------------------------------
8118       double precision function eello_turn6(i,jj,kk)
8119       implicit real*8 (a-h,o-z)
8120       include 'DIMENSIONS'
8121       include 'DIMENSIONS.ZSCOPT'
8122       include 'COMMON.IOUNITS'
8123       include 'COMMON.CHAIN'
8124       include 'COMMON.DERIV'
8125       include 'COMMON.INTERACT'
8126       include 'COMMON.CONTACTS'
8127       include 'COMMON.TORSION'
8128       include 'COMMON.VAR'
8129       include 'COMMON.GEO'
8130       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8131      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8132      &  ggg1(3),ggg2(3)
8133       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8134      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8135 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8136 C           the respective energy moment and not to the cluster cumulant.
8137       eello_turn6=0.0d0
8138       j=i+4
8139       k=i+1
8140       l=i+3
8141       iti=itortyp(itype(i))
8142       itk=itortyp(itype(k))
8143       itk1=itortyp(itype(k+1))
8144       itl=itortyp(itype(l))
8145       itj=itortyp(itype(j))
8146 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8147 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8148 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8149 cd        eello6=0.0d0
8150 cd        return
8151 cd      endif
8152 cd      write (iout,*)
8153 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8154 cd     &   ' and',k,l
8155 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8156       do iii=1,2
8157         do kkk=1,5
8158           do lll=1,3
8159             derx_turn(lll,kkk,iii)=0.0d0
8160           enddo
8161         enddo
8162       enddo
8163 cd      eij=1.0d0
8164 cd      ekl=1.0d0
8165 cd      ekont=1.0d0
8166       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8167 cd      eello6_5=0.0d0
8168 cd      write (2,*) 'eello6_5',eello6_5
8169 #ifdef MOMENT
8170       call transpose2(AEA(1,1,1),auxmat(1,1))
8171       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8172       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8173       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8174 #else
8175       s1 = 0.0d0
8176 #endif
8177       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8178       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8179       s2 = scalar2(b1(1,itk),vtemp1(1))
8180 #ifdef MOMENT
8181       call transpose2(AEA(1,1,2),atemp(1,1))
8182       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8183       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8184       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8185 #else
8186       s8=0.0d0
8187 #endif
8188       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8189       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8190       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8191 #ifdef MOMENT
8192       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8193       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8194       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8195       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8196       ss13 = scalar2(b1(1,itk),vtemp4(1))
8197       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8198 #else
8199       s13=0.0d0
8200 #endif
8201 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8202 c      s1=0.0d0
8203 c      s2=0.0d0
8204 c      s8=0.0d0
8205 c      s12=0.0d0
8206 c      s13=0.0d0
8207       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8208       if (calc_grad) then
8209 C Derivatives in gamma(i+2)
8210 #ifdef MOMENT
8211       call transpose2(AEA(1,1,1),auxmatd(1,1))
8212       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8213       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8214       call transpose2(AEAderg(1,1,2),atempd(1,1))
8215       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8216       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8217 #else
8218       s8d=0.0d0
8219 #endif
8220       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8221       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8222       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8223 c      s1d=0.0d0
8224 c      s2d=0.0d0
8225 c      s8d=0.0d0
8226 c      s12d=0.0d0
8227 c      s13d=0.0d0
8228       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8229 C Derivatives in gamma(i+3)
8230 #ifdef MOMENT
8231       call transpose2(AEA(1,1,1),auxmatd(1,1))
8232       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8233       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8234       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8235 #else
8236       s1d=0.0d0
8237 #endif
8238       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8239       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8240       s2d = scalar2(b1(1,itk),vtemp1d(1))
8241 #ifdef MOMENT
8242       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8243       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8244 #endif
8245       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8246 #ifdef MOMENT
8247       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8248       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8249       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8250 #else
8251       s13d=0.0d0
8252 #endif
8253 c      s1d=0.0d0
8254 c      s2d=0.0d0
8255 c      s8d=0.0d0
8256 c      s12d=0.0d0
8257 c      s13d=0.0d0
8258 #ifdef MOMENT
8259       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8260      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8261 #else
8262       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8263      &               -0.5d0*ekont*(s2d+s12d)
8264 #endif
8265 C Derivatives in gamma(i+4)
8266       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8267       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8268       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8269 #ifdef MOMENT
8270       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8271       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8272       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8273 #else
8274       s13d = 0.0d0
8275 #endif
8276 c      s1d=0.0d0
8277 c      s2d=0.0d0
8278 c      s8d=0.0d0
8279 C      s12d=0.0d0
8280 c      s13d=0.0d0
8281 #ifdef MOMENT
8282       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8283 #else
8284       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8285 #endif
8286 C Derivatives in gamma(i+5)
8287 #ifdef MOMENT
8288       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8289       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8290       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8291 #else
8292       s1d = 0.0d0
8293 #endif
8294       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8295       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8296       s2d = scalar2(b1(1,itk),vtemp1d(1))
8297 #ifdef MOMENT
8298       call transpose2(AEA(1,1,2),atempd(1,1))
8299       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8300       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8301 #else
8302       s8d = 0.0d0
8303 #endif
8304       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8305       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8306 #ifdef MOMENT
8307       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8308       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8309       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8310 #else
8311       s13d = 0.0d0
8312 #endif
8313 c      s1d=0.0d0
8314 c      s2d=0.0d0
8315 c      s8d=0.0d0
8316 c      s12d=0.0d0
8317 c      s13d=0.0d0
8318 #ifdef MOMENT
8319       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8320      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8321 #else
8322       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8323      &               -0.5d0*ekont*(s2d+s12d)
8324 #endif
8325 C Cartesian derivatives
8326       do iii=1,2
8327         do kkk=1,5
8328           do lll=1,3
8329 #ifdef MOMENT
8330             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8331             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8332             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8333 #else
8334             s1d = 0.0d0
8335 #endif
8336             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8337             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8338      &          vtemp1d(1))
8339             s2d = scalar2(b1(1,itk),vtemp1d(1))
8340 #ifdef MOMENT
8341             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8342             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8343             s8d = -(atempd(1,1)+atempd(2,2))*
8344      &           scalar2(cc(1,1,itl),vtemp2(1))
8345 #else
8346             s8d = 0.0d0
8347 #endif
8348             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8349      &           auxmatd(1,1))
8350             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8351             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8352 c      s1d=0.0d0
8353 c      s2d=0.0d0
8354 c      s8d=0.0d0
8355 c      s12d=0.0d0
8356 c      s13d=0.0d0
8357 #ifdef MOMENT
8358             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8359      &        - 0.5d0*(s1d+s2d)
8360 #else
8361             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8362      &        - 0.5d0*s2d
8363 #endif
8364 #ifdef MOMENT
8365             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8366      &        - 0.5d0*(s8d+s12d)
8367 #else
8368             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8369      &        - 0.5d0*s12d
8370 #endif
8371           enddo
8372         enddo
8373       enddo
8374 #ifdef MOMENT
8375       do kkk=1,5
8376         do lll=1,3
8377           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8378      &      achuj_tempd(1,1))
8379           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8380           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8381           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8382           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8383           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8384      &      vtemp4d(1))
8385           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8386           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8387           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8388         enddo
8389       enddo
8390 #endif
8391 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8392 cd     &  16*eel_turn6_num
8393 cd      goto 1112
8394       if (j.lt.nres-1) then
8395         j1=j+1
8396         j2=j-1
8397       else
8398         j1=j-1
8399         j2=j-2
8400       endif
8401       if (l.lt.nres-1) then
8402         l1=l+1
8403         l2=l-1
8404       else
8405         l1=l-1
8406         l2=l-2
8407       endif
8408       do ll=1,3
8409         ggg1(ll)=eel_turn6*g_contij(ll,1)
8410         ggg2(ll)=eel_turn6*g_contij(ll,2)
8411         ghalf=0.5d0*ggg1(ll)
8412 cd        ghalf=0.0d0
8413         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8414      &    +ekont*derx_turn(ll,2,1)
8415         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8416         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8417      &    +ekont*derx_turn(ll,4,1)
8418         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8419         ghalf=0.5d0*ggg2(ll)
8420 cd        ghalf=0.0d0
8421         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8422      &    +ekont*derx_turn(ll,2,2)
8423         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8424         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8425      &    +ekont*derx_turn(ll,4,2)
8426         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8427       enddo
8428 cd      goto 1112
8429       do m=i+1,j-1
8430         do ll=1,3
8431           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8432         enddo
8433       enddo
8434       do m=k+1,l-1
8435         do ll=1,3
8436           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8437         enddo
8438       enddo
8439 1112  continue
8440       do m=i+2,j2
8441         do ll=1,3
8442           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8443         enddo
8444       enddo
8445       do m=k+2,l2
8446         do ll=1,3
8447           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8448         enddo
8449       enddo
8450 cd      do iii=1,nres-3
8451 cd        write (2,*) iii,g_corr6_loc(iii)
8452 cd      enddo
8453       endif
8454       eello_turn6=ekont*eel_turn6
8455 cd      write (2,*) 'ekont',ekont
8456 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8457       return
8458       end
8459 crc-------------------------------------------------
8460       SUBROUTINE MATVEC2(A1,V1,V2)
8461       implicit real*8 (a-h,o-z)
8462       include 'DIMENSIONS'
8463       DIMENSION A1(2,2),V1(2),V2(2)
8464 c      DO 1 I=1,2
8465 c        VI=0.0
8466 c        DO 3 K=1,2
8467 c    3     VI=VI+A1(I,K)*V1(K)
8468 c        Vaux(I)=VI
8469 c    1 CONTINUE
8470
8471       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
8472       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
8473
8474       v2(1)=vaux1
8475       v2(2)=vaux2
8476       END
8477 C---------------------------------------
8478       SUBROUTINE MATMAT2(A1,A2,A3)
8479       implicit real*8 (a-h,o-z)
8480       include 'DIMENSIONS'
8481       DIMENSION A1(2,2),A2(2,2),A3(2,2)
8482 c      DIMENSION AI3(2,2)
8483 c        DO  J=1,2
8484 c          A3IJ=0.0
8485 c          DO K=1,2
8486 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
8487 c          enddo
8488 c          A3(I,J)=A3IJ
8489 c       enddo
8490 c      enddo
8491
8492       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
8493       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
8494       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
8495       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
8496
8497       A3(1,1)=AI3_11
8498       A3(2,1)=AI3_21
8499       A3(1,2)=AI3_12
8500       A3(2,2)=AI3_22
8501       END
8502
8503 c-------------------------------------------------------------------------
8504       double precision function scalar2(u,v)
8505       implicit none
8506       double precision u(2),v(2)
8507       double precision sc
8508       integer i
8509       scalar2=u(1)*v(1)+u(2)*v(2)
8510       return
8511       end
8512
8513 C-----------------------------------------------------------------------------
8514
8515       subroutine transpose2(a,at)
8516       implicit none
8517       double precision a(2,2),at(2,2)
8518       at(1,1)=a(1,1)
8519       at(1,2)=a(2,1)
8520       at(2,1)=a(1,2)
8521       at(2,2)=a(2,2)
8522       return
8523       end
8524 c--------------------------------------------------------------------------
8525       subroutine transpose(n,a,at)
8526       implicit none
8527       integer n,i,j
8528       double precision a(n,n),at(n,n)
8529       do i=1,n
8530         do j=1,n
8531           at(j,i)=a(i,j)
8532         enddo
8533       enddo
8534       return
8535       end
8536 C---------------------------------------------------------------------------
8537       subroutine prodmat3(a1,a2,kk,transp,prod)
8538       implicit none
8539       integer i,j
8540       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
8541       logical transp
8542 crc      double precision auxmat(2,2),prod_(2,2)
8543
8544       if (transp) then
8545 crc        call transpose2(kk(1,1),auxmat(1,1))
8546 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
8547 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8548
8549            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
8550      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
8551            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
8552      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
8553            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
8554      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
8555            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
8556      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
8557
8558       else
8559 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
8560 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
8561
8562            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
8563      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
8564            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
8565      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
8566            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
8567      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
8568            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
8569      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
8570
8571       endif
8572 c      call transpose2(a2(1,1),a2t(1,1))
8573
8574 crc      print *,transp
8575 crc      print *,((prod_(i,j),i=1,2),j=1,2)
8576 crc      print *,((prod(i,j),i=1,2),j=1,2)
8577
8578       return
8579       end
8580 C-----------------------------------------------------------------------------
8581       double precision function scalar(u,v)
8582       implicit none
8583       double precision u(3),v(3)
8584       double precision sc
8585       integer i
8586       sc=0.0d0
8587       do i=1,3
8588         sc=sc+u(i)*v(i)
8589       enddo
8590       scalar=sc
8591       return
8592       end
8593 C-----------------------------------------------------------------------
8594       double precision function sscale(r)
8595       double precision r,gamm
8596       include "COMMON.SPLITELE"
8597       if(r.lt.r_cut-rlamb) then
8598         sscale=1.0d0
8599       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8600         gamm=(r-(r_cut-rlamb))/rlamb
8601         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
8602       else
8603         sscale=0d0
8604       endif
8605       return
8606       end
8607 C-----------------------------------------------------------------------
8608 C-----------------------------------------------------------------------
8609       double precision function sscagrad(r)
8610       double precision r,gamm
8611       include "COMMON.SPLITELE"
8612       if(r.lt.r_cut-rlamb) then
8613         sscagrad=0.0d0
8614       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8615         gamm=(r-(r_cut-rlamb))/rlamb
8616         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
8617       else
8618         sscagrad=0.0d0
8619       endif
8620       return
8621       end
8622 C-----------------------------------------------------------------------
8623 C-----------------------------------------------------------------------
8624       double precision function sscalelip(r)
8625       double precision r,gamm
8626       include "COMMON.SPLITELE"
8627 C      if(r.lt.r_cut-rlamb) then
8628 C        sscale=1.0d0
8629 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8630 C        gamm=(r-(r_cut-rlamb))/rlamb
8631         sscalelip=1.0d0+r*r*(2*r-3.0d0)
8632 C      else
8633 C        sscale=0d0
8634 C      endif
8635       return
8636       end
8637 C-----------------------------------------------------------------------
8638       double precision function sscagradlip(r)
8639       double precision r,gamm
8640       include "COMMON.SPLITELE"
8641 C     if(r.lt.r_cut-rlamb) then
8642 C        sscagrad=0.0d0
8643 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
8644 C        gamm=(r-(r_cut-rlamb))/rlamb
8645         sscagradlip=r*(6*r-6.0d0)
8646 C      else
8647 C        sscagrad=0.0d0
8648 C      endif
8649       return
8650       end
8651